diff --git a/Pugs.cabal b/Pugs.cabal --- a/Pugs.cabal +++ b/Pugs.cabal @@ -1,5 +1,5 @@ Name : Pugs -Version : 6.2.13.8 +Version : 6.2.13.9 license : BSD3 license-file : LICENSE cabal-version : >= 1.2 @@ -13,10 +13,40 @@ description : A Perl 6 Implementation author : Audrey Tang tested-with : GHC --- c-sources : src/perl5/p5embed.c --- hs-source-dirs : src --- extensions : ForeignFunctionInterface --- include-dirs : /usr/local/include /opt/local/include /usr/local/lib/perl5/5.9.5/darwin-2level/CORE +data-files : + blib6/pugs/perl5/lib/Parse/Yapp/Driver.pm + blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm + blib6/pugs/perl5/lib/Parse/Yapp/Lalr.pm + blib6/pugs/perl5/lib/Parse/Yapp/Options.pm + blib6/pugs/perl5/lib/Parse/Yapp/Output.pm + blib6/pugs/perl5/lib/Parse/Yapp/Parse.pm + blib6/pugs/perl5/lib/Parse/Yapp.pm + blib6/pugs/perl5/lib/Pugs/AST/Expression.pm + blib6/pugs/perl5/lib/Pugs/Compiler/Grammar.pm + blib6/pugs/perl5/lib/Pugs/Compiler/Regex.pm + blib6/pugs/perl5/lib/Pugs/Compiler/RegexPerl5.pm + blib6/pugs/perl5/lib/Pugs/Compiler/Rule.pm + blib6/pugs/perl5/lib/Pugs/Compiler/Token.pm + blib6/pugs/perl5/lib/Pugs/Emitter/Grammar/Perl5.pm + blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Parsec.pm + blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/CharClass.pm + blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Ratchet.pm + blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Regex.pm + blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5.pm + blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl6/Ratchet.pm + blib6/pugs/perl5/lib/Pugs/Grammar/Base.pm + blib6/pugs/perl5/lib/Pugs/Grammar/Precedence.pm + blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pm + blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pmc + blib6/pugs/perl5/lib/Pugs/Grammar/Rule2.pm + blib6/pugs/perl5/lib/Pugs/Grammar/RulePure.pm + blib6/pugs/perl5/lib/Pugs/Runtime/Common.pm + blib6/pugs/perl5/lib/Pugs/Runtime/Match/HsBridge.pm + blib6/pugs/perl5/lib/Pugs/Runtime/Match.pm + blib6/pugs/perl5/lib/Pugs/Runtime/Regex.pm + blib6/pugs/perl5/lib/Pugs/Runtime/Rule.pm + blib6/pugs/perl5/lib/Pugs/Runtime/StrPos.pm + blib6/pugs/perl5/lib/Pugs/Runtime/Tracer.pm extra-source-files: src/Pugs.hs src/Pugs/AST.hs @@ -115,13 +145,9 @@ src/Pugs/Val/Code.hs src/Pugs/Version.hs -flag Optimize - description: Enable optimizations - default: False - --- flag Debug --- description: Enable debugging hooks --- default: False +flag Perl5 + description: Enable Perl 5 Embedding + default: True executable pugs main-is: Main.hs @@ -130,27 +156,22 @@ build-depends: base, haskell98, filepath, mtl, stm, parsec < 3.0.0, network, pretty, time, random, process, containers, bytestring, - array, directory, utf8-string, binary, haskeline >= 0.2, + array, directory, utf8-string, binary, haskeline >= 0.2.1, MetaObject >= 0.0.4, HsParrot >= 0.0.2, - pugs-compat >= 0.0.4, + pugs-compat >= 0.0.5, pugs-DrIFT >= 2.2.3.0, stringtable-atom >= 0.0.4, HsSyck >= 0.44 -- HsPerl5 - if flag(Optimize) - ghc-options: -O2 - - -- if flag(Debug) - -- ghc-options: -prof -auto-all - - -- cpp-options: -DPUGS_HAVE_PERL5=1 + if flag(Perl5) + cpp-options: -DPUGS_HAVE_PERL5=1 c-sources: cbits/Prelude_pm.c cbits/Test_pm.c - -- perl5/p5embed.c + perl5/p5embed.c - -- includes: - -- perl5/p5embed.h + includes: + perl5/p5embed.h diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,3 +1,8 @@ -#!/usr/bin/env runhaskell +#!/usr/bin/env runghc > import Distribution.Simple -> main = defaultMain +> import System.Cmd (rawSystem) +> +> main :: IO () +> main = writeBuildInfo >> defaultMainWithHooks defaultUserHooks +> where +> writeBuildInfo = rawSystem "perl" ["Configure.PL"] diff --git a/blib6/pugs/perl5/lib/Parse/Yapp.pm b/blib6/pugs/perl5/lib/Parse/Yapp.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Parse/Yapp.pm @@ -0,0 +1,512 @@ +# +# Module Parse::Yapp.pm. +# +# Copyright (c) 1998-2001, Francois Desarmenien, all right reserved. +# +# See the Copyright section at the end of the Parse/Yapp.pm pod section +# for usage and distribution rights. +# +# +package Parse::Yapp; + +use strict; +use vars qw($VERSION @ISA); +@ISA = qw(Parse::Yapp::Output); + +use Parse::Yapp::Output; + +# $VERSION is in Parse/Yapp/Driver.pm + + +1; + +__END__ + +=head1 NAME + +Parse::Yapp - Perl extension for generating and using LALR parsers. + +=head1 SYNOPSIS + + yapp -m MyParser grammar_file.yp + + ... + + use MyParser; + + $parser=new MyParser(); + $value=$parser->YYParse(yylex => \&lexer_sub, yyerror => \&error_sub); + + $nberr=$parser->YYNberr(); + + $parser->YYData->{DATA}= [ 'Anything', 'You Want' ]; + + $data=$parser->YYData->{DATA}[0]; + +=head1 DESCRIPTION + +Parse::Yapp (Yet Another Perl Parser compiler) is a collection of modules +that let you generate and use yacc like thread safe (reentrant) parsers with +perl object oriented interface. + +The script yapp is a front-end to the Parse::Yapp module and let you +easily create a Perl OO parser from an input grammar file. + +=head2 The Grammar file + +=over 4 + +=item C + +Through all your files, comments are either Perl style, introduced by I<#> +up to the end of line, or C style, enclosed between I and I<*/>. + + +=item C + + +Through all the grammar files, two kind of symbols may appear: +I symbols, called also I symbols, +which are the names of your rules, and I symbols, called +also I. + +Tokens are the symbols your lexer function will feed your parser with +(see below). They are of two flavours: symbolic tokens and string +literals. + +Non-terminals and symbolic tokens share the same identifier syntax: + + [A-Za-z][A-Za-z0-9_]* + +String literals are enclosed in single quotes and can contain almost +anything. They will be output to your parser file double-quoted, making +any special character as such. '"', '$' and '@' will be automatically +quoted with '\', making their writing more natural. On the other hand, +if you need a single quote inside your literal, just quote it with '\'. + +You cannot have a literal I<'error'> in your grammar as it would +confuse the driver with the I token. Use a symbolic token instead. +In case you inadvertently use it, this will produce a warning telling you +you should have written it I and will treat it as if it were the +I token, which is certainly NOT what you meant. + + +=item C + +It is very close to yacc syntax (in fact, I should compile +a clean I grammar without any modification, whereas the opposite +is not true). + +This file is divided in three sections, separated by C<%%>: + + header section + %% + rules section + %% + footer section + +=over 4 + +=item B section may optionally contain: + +=item * + +One or more code blocks enclosed inside C<%{> and C<%}> just like in +yacc. They may contain any valid Perl code and will be copied verbatim +at the very beginning of the parser module. They are not as useful as +they are in yacc, but you can use them, for example, for global variable +declarations, though you will notice later that such global variables can +be avoided to make a reentrant parser module. + +=item * + +Precedence declarations, introduced by C<%left>, C<%right> and C<%nonassoc> +specifying associativity, followed by the list of tokens or litterals +having the same precedence and associativity. +The precedence beeing the latter declared will be having the highest level. +(see the yacc or bison manuals for a full explanation of how they work, +as they are implemented exactly the same way in Parse::Yapp) + +=item * + +C<%start> followed by a rule's left hand side, declaring this rule to +be the starting rule of your grammar. The default, when C<%start> is not +used, is the first rule in your grammar section. + +=item * + +C<%token> followed by a list of symbols, forcing them to be recognized +as tokens, generating a syntax error if used in the left hand side of +a rule declaration. +Note that in Parse::Yapp, you I need to declare tokens as in yacc: any +symbol not appearing as a left hand side of a rule is considered to be +a token. +Other yacc declarations or constructs such as C<%type> and C<%union> are +parsed but (almost) ignored. + +=item * + +C<%expect> followed by a number, suppress warnings about number of Shift/Reduce +conflicts when both numbers match, a la bison. + + +=item B contains your grammar rules: + +A rule is made of a left-hand-side symbol, followed by a C<':'> and one +or more right-hand-sides separated by C<'|'> and terminated by a C<';'>: + + exp: exp '+' exp + | exp '-' exp + ; + +A right hand side may be empty: + + input: #empty + | input line + ; + +(if you have more than one empty rhs, Parse::Yapp will issue a warning, +as this is usually a mistake, and you will certainly have a reduce/reduce +conflict) + + +A rhs may be followed by an optional C<%prec> directive, followed +by a token, giving the rule an explicit precedence (see yacc manuals +for its precise meaning) and optionnal semantic action code block (see +below). + + exp: '-' exp %prec NEG { -$_[1] } + | exp '+' exp { $_[1] + $_[3] } + | NUM + ; + +Note that in Parse::Yapp, a lhs I appear more than once as +a rule name (This differs from yacc). + + +=item C + +may contain any valid Perl code and will be appended at the very end +of your parser module. Here you can write your lexer, error report +subs and anything relevant to you parser. + +=item C + +Semantic actions are run every time a I occurs in the +parsing flow and they must return a semantic value. + +They are (usually, but see below C) written at +the very end of the rhs, enclosed with C<{ }>, and are copied verbatim +to your parser file, inside of the rules table. + +Be aware that matching braces in Perl is much more difficult than +in C: inside strings they don't need to match. While in C it is +very easy to detect the beginning of a string construct, or a +single character, it is much more difficult in Perl, as there +are so many ways of writing such literals. So there is no check +for that today. If you need a brace in a double-quoted string, just +quote it (C<\{> or C<\}>). For single-quoted strings, you will need +to make a comment matching it I. +Sorry for the inconvenience. + + { + "{ My string block }". + "\{ My other string block \}". + qq/ My unmatched brace \} /. + # Force the match: { + q/ for my closing brace } / + q/ My opening brace { / + # must be closed: } + } + +All of these constructs should work. + + +In Parse::Yapp, semantic actions are called like normal Perl sub calls, +with their arguments passed in C<@_>, and their semantic value are +their return values. + +$_[1] to $_[n] are the parameters just as $1 to $n in yacc, while +$_[0] is the parser object itself. + +Having $_[0] beeing the parser object itself allows you to call +parser methods. Thats how the yacc macros are implemented: + + yyerrok is done by calling $_[0]->YYErrok + YYERROR is done by calling $_[0]->YYError + YYACCEPT is done by calling $_[0]->YYAccept + YYABORT is done by calling $_[0]->YYAbort + +All those methods explicitly return I, for convenience. + + YYRECOVERING is done by calling $_[0]->YYRecovering + +Four useful methods in error recovery sub + + $_[0]->YYCurtok + $_[0]->YYCurval + $_[0]->YYExpect + $_[0]->YYLexer + +return respectivly the current input token that made the parse fail, +its semantic value (both can be used to modify their values too, but +I ! See I section for +an example), a list which contains the tokens the parser expected when +the failure occured and a reference to the lexer routine. + +Note that if C<$_[0]-EYYCurtok> is declared as a C<%nonassoc> token, +it can be included in C<$_[0]-EYYExpect> list whenever the input +try to use it in an associative way. This is not a bug: the token +IS expected to report an error if encountered. + +To detect such a thing in your error reporting sub, the following +example should do the trick: + + grep { $_[0]->YYCurtok eq $_ } $_[0]->YYExpect + and do { + #Non-associative token used in an associative expression + }; + +Accessing semantics values on the left of your reducing rule is done +through the method + + $_[0]->YYSemval( index ) + +where index is an integer. Its value being I<1 .. n> returns the same values +than I<$_[1] .. $_[n]>, but I<-n .. 0> returns values on the left of the rule +beeing reduced (It is related to I<$-n .. $0 .. $n> in yacc, but you +cannot use I<$_[0]> or I<$_[-n]> constructs in Parse::Yapp for obvious reasons) + + +There is also a provision for a user data area in the parser object, +accessed by the method: + + $_[0]->YYData + +which returns a reference to an anonymous hash, which let you have +all of your parsing data held inside the object (see the Calc.yp +or ParseYapp.yp files in the distribution for some examples). +That's how you can make you parser module reentrant: all of your +module states and variables are held inside the parser object. + +Note: unfortunatly, method calls in Perl have a lot of overhead, + and when YYData is used, it may be called a huge number + of times. If your are not a *real* purist and efficiency + is your concern, you may access directly the user-space + in the object: $parser->{USER} wich is a reference to an + anonymous hash array, and then benchmark. + +If no action is specified for a rule, the equivalant of a default +action is run, which returns the first parameter: + + { $_[1] } + +=item C + +It is also possible to embed semantic actions inside of a rule: + + typedef: TYPE { $type = $_[1] } identlist { ... } ; + +When the Parse::Yapp's parser encounter such an embedded action, it modifies +the grammar as if you wrote (although @x-1 is not a legal lhs value): + + @x-1: /* empty */ { $type = $_[1] }; + typedef: TYPE @x-1 identlist { ... } ; + +where I is a sequential number incremented for each "in rule" action, +and I<-1> represents the "dot position" in the rule where the action arises. + +In such actions, you can use I<$_[1]..$_[n]> variables, which are the +semantic values on the left of your action. + +Be aware that the way Parse::Yapp modifies your grammar because of +I can produce, in some cases, spurious conflicts +that wouldn't happen otherwise. + +=item C + +Now that you grammar file is written, you can use yapp on it +to generate your parser module: + + yapp -v Calc.yp + +will create two files F, your parser module, and F +a verbose output of your parser rules, conflicts, warnings, states +and summary. + +What your are missing now is a lexer routine. + +=item C + +is called each time the parser need to read the next token. + +It is called with only one argument that is the parser object itself, +so you can access its methods, specially the + + $_[0]->YYData + +data area. + +It is its duty to return the next token and value to the parser. +They C be returned as a list of two variables, the first one +is the token known by the parser (symbolic or literal), the second +one beeing anything you want (usualy the content of the token, or the +literal value) from a simple scalar value to any complex reference, +as the parsing driver never use it but to call semantic actions: + + ( 'NUMBER', $num ) +or + ( '>=', '>=' ) +or + ( 'ARRAY', [ @values ] ) + +When the lexer reach the end of input, it must return the C<''> +empty token with an undef value: + + ( '', undef ) + +Note that your lexer should I return C<'error'> as token +value: for the driver, this is the error token used for error +recovery and would lead to odd reactions. + +Now that you have your lexer written, maybe you will need to output +meaningful error messages, instead of the default which is to print +'Parse error.' on STDERR. + +So you will need an Error reporting sub. + +item C + +If you want one, write it knowing that it is passed as parameter +the parser object. So you can share information whith the lexer +routine quite easily. + +You can also use the C<$_[0]-EYYErrok> method in it, which will +resume parsing as if no error occured. Of course, since the invalid +token is still invalid, you're supposed to fix the problem by +yourself. + +The method C<$_[0]-EYYLexer> may help you, as it returns a reference +to the lexer routine, and can be called as + + ($tok,$val)=&{$_[0]->Lexer} + +to get the next token and semantic value from the input stream. To +make them current for the parser, use: + + ($_[0]->YYCurtok, $_[0]->YYCurval) = ($tok, $val) + +and know what you're doing... + +=item C + +Now you've got everything to do the parsing. + +First, use the parser module: + + use Calc; + +Then create the parser object: + + $parser=new Calc; + +Now, call the YYParse method, telling it where to find the lexer +and error report subs: + + $result=$parser->YYParse(yylex => \&Lexer, + yyerror => \&ErrorReport); + +(assuming Lexer and ErrorReport subs have been written in your current +package) + +The order in which parameters appear is unimportant. + +Et voila. + +The YYParse method will do the parse, then return the last semantic +value returned, or undef if error recovery cannot recover. + +If you need to be sure the parse has been successful (in case your +last returned semantic value I undef) make a call to: + + $parser->YYNberr() + +which returns the total number of time the error reporting sub has been called. + +=item C + +in Parse::Yapp is implemented the same way it is in yacc. + +=item C + +To debug your parser, you can call the YYParse method with a debug parameter: + + $parser->YYParse( ... , yydebug => value, ... ) + +where value is a bitfield, each bit representing a specific debug output: + + Bit Value Outputs + 0x01 Token reading (useful for Lexer debugging) + 0x02 States information + 0x04 Driver actions (shifts, reduces, accept...) + 0x08 Parse Stack dump + 0x10 Error Recovery tracing + +To have a full debugging ouput, use + + debug => 0x1F + +Debugging output is sent to STDERR, and be aware that it can produce +C outputs. + +=item C + +By default, the parser modules generated will need the Parse::Yapp +module installed on the system to run. They use the Parse::Yapp::Driver +which can be safely shared between parsers in the same script. + +In the case you'd prefer to have a standalone module generated, use +the C<-s> switch with yapp: this will automagically copy the driver +code into your module so you can use/distribute it without the need +of the Parse::Yapp module, making it really a C. + +If you do so, please remember to include Parse::Yapp's copyright notice +in your main module copyright, so others can know about Parse::Yapp module. + +=item C + +by default will be included in the generated parser module, which will help +to find the guilty line in your source file in case of a syntax error. +You can disable this feature by compiling your grammar with yapp using +the C<-n> switch. + +=back + +=head1 BUGS AND SUGGESTIONS + +If you find bugs, think of anything that could improve Parse::Yapp +or have any questions related to it, feel free to contact the author. + +=head1 AUTHOR + +Francois Desarmenien + +=head1 SEE ALSO + +yapp(1) perl(1) yacc(1) bison(1). + +=head1 COPYRIGHT + +The Parse::Yapp module and its related modules and shell scripts are copyright +(c) 1998-2001 Francois Desarmenien, France. All rights reserved. + +You may use and distribute them under the terms of either +the GNU General Public License or the Artistic License, +as specified in the Perl README file. + +If you use the "standalone parser" option so people don't need to install +Parse::Yapp on their systems in order to run you software, this copyright +noticed should be included in your software copyright too, and the copyright +notice in the embedded driver should be left untouched. + +=cut diff --git a/blib6/pugs/perl5/lib/Parse/Yapp/Driver.pm b/blib6/pugs/perl5/lib/Parse/Yapp/Driver.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/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() { + /^\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; + diff --git a/blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm b/blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Parse/Yapp/Grammar.pm @@ -0,0 +1,381 @@ +# +# Module Parse::Yapp::Grammar +# +# (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::Grammar; +@ISA=qw( Parse::Yapp::Options ); + +require 5.004; + +use Carp; +use strict; +use Parse::Yapp::Options; +use Parse::Yapp::Parse; + +############### +# Constructor # +############### +sub new { + my($class)=shift; + my($values); + + my($self)=$class->SUPER::new(@_); + + my($parser)=new Parse::Yapp::Parse; + + defined($self->Option('input')) + or croak "No input grammar"; + + $values = $parser->Parse($self->Option('input')); + + undef($parser); + + $$self{GRAMMAR}=_ReduceGrammar($values); + + ref($class) + and $class=ref($class); + + bless($self, $class); +} + +########### +# Methods # +########### +########################## +# Method To View Grammar # +########################## +sub ShowRules { + my($self)=shift; + my($rules)=$$self{GRAMMAR}{RULES}; + my($ruleno)=-1; + my($text); + + for (@$rules) { + my($lhs,$rhs)=@$_; + + $text.=++$ruleno.":\t".$lhs." -> "; + if(@$rhs) { + $text.=join(' ',map { $_ eq chr(0) ? '$end' : $_ } @$rhs); + } + else { + $text.="/* empty */"; + } + $text.="\n"; + } + $text; +} + +########################### +# Method To View Warnings # +########################### +sub Warnings { + my($self)=shift; + my($text); + my($grammar)=$$self{GRAMMAR}; + + exists($$grammar{UUTERM}) + and do { + $text="Unused terminals:\n\n"; + for (@{$$grammar{UUTERM}}) { + $text.="\t$$_[0], declared line $$_[1]\n"; + } + $text.="\n"; + }; + exists($$grammar{UUNTERM}) + and do { + $text.="Useless non-terminals:\n\n"; + for (@{$$grammar{UUNTERM}}) { + $text.="\t$$_[0], declared line $$_[1]\n"; + } + $text.="\n"; + }; + exists($$grammar{UURULES}) + and do { + $text.="Useless rules:\n\n"; + for (@{$$grammar{UURULES}}) { + $text.="\t$$_[0] -> ".join(' ',@{$$_[1]})."\n"; + } + $text.="\n"; + }; + $text; +} + +###################################### +# Method to get summary about parser # +###################################### +sub Summary { + my($self)=shift; + my($text); + + $text ="Number of rules : ". + scalar(@{$$self{GRAMMAR}{RULES}})."\n"; + $text.="Number of terminals : ". + scalar(keys(%{$$self{GRAMMAR}{TERM}}))."\n"; + $text.="Number of non-terminals : ". + scalar(keys(%{$$self{GRAMMAR}{NTERM}}))."\n"; + $text; +} + +############################### +# Method to Ouput rules table # +############################### +sub RulesTable { + my($self)=shift; + my($inputfile)=$self->Option('inputfile'); + my($linenums)=$self->Option('linenumbers'); + my($rules)=$$self{GRAMMAR}{RULES}; + my($ruleno); + my($text); + + defined($inputfile) + or $inputfile = 'unkown'; + + $text="[\n\t"; + + $text.=join(",\n\t", + map { + my($lhs,$rhs,$code)=@$_[0,1,3]; + my($len)=scalar(@$rhs); + my($text); + + $text.="[#Rule ".$ruleno++."\n\t\t '$lhs', $len,"; + if($code) { + $text.= "\nsub". + ( $linenums + ? qq(\n#line $$code[1] "$inputfile"\n) + : " "). + "{$$code[0]}"; + } + else { + $text.=' undef'; + } + $text.="\n\t]"; + + $text; + } @$rules); + + $text.="\n]"; + + $text; +} + +################################ +# Methods to get HEAD and TAIL # +################################ +sub Head { + my($self)=shift; + my($inputfile)=$self->Option('inputfile'); + my($linenums)=$self->Option('linenumbers'); + my($text); + + $$self{GRAMMAR}{HEAD}[0] + or return ''; + + defined($inputfile) + or $inputfile = 'unkown'; + + for (@{$$self{GRAMMAR}{HEAD}}) { + $linenums + and $text.=qq(#line $$_[1] "$inputfile"\n); + $text.=$$_[0]; + } + $text +} + +sub Tail { + my($self)=shift; + my($inputfile)=$self->Option('inputfile'); + my($linenums)=$self->Option('linenumbers'); + my($text); + + $$self{GRAMMAR}{TAIL}[0] + or return ''; + + defined($inputfile) + or $inputfile = 'unkown'; + + $linenums + and $text=qq(#line $$self{GRAMMAR}{TAIL}[1] "$inputfile"\n); + $text.=$$self{GRAMMAR}{TAIL}[0]; + + $text +} + + +################# +# Private Stuff # +################# + +sub _UsefulRules { + my($rules,$nterm) = @_; + my($ufrules,$ufnterm); + my($done); + + $ufrules=pack('b'.@$rules); + $ufnterm={}; + + vec($ufrules,0,1)=1; #start rules IS always useful + + RULE: + for (1..$#$rules) { # Ignore start rule + for my $sym (@{$$rules[$_][1]}) { + exists($$nterm{$sym}) + and next RULE; + } + vec($ufrules,$_,1)=1; + ++$$ufnterm{$$rules[$_][0]}; + } + + do { + $done=1; + + RULE: + for (grep { vec($ufrules,$_,1) == 0 } 1..$#$rules) { + for my $sym (@{$$rules[$_][1]}) { + exists($$nterm{$sym}) + and not exists($$ufnterm{$sym}) + and next RULE; + } + vec($ufrules,$_,1)=1; + exists($$ufnterm{$$rules[$_][0]}) + or do { + $done=0; + ++$$ufnterm{$$rules[$_][0]}; + }; + } + + }until($done); + + ($ufrules,$ufnterm) + +}#_UsefulRules + +sub _Reachable { + my($rules,$nterm,$term,$ufrules,$ufnterm)=@_; + my($reachable); + my(@fifo)=( 0 ); + + $reachable={ '$start' => 1 }; #$start is always reachable + + while(@fifo) { + my($ruleno)=shift(@fifo); + + for my $sym (@{$$rules[$ruleno][1]}) { + + exists($$term{$sym}) + and do { + ++$$reachable{$sym}; + next; + }; + + ( not exists($$ufnterm{$sym}) + or exists($$reachable{$sym}) ) + and next; + + ++$$reachable{$sym}; + push(@fifo, grep { vec($ufrules,$_,1) } @{$$nterm{$sym}}); + } + } + + $reachable + +}#_Reachable + +sub _SetNullable { + my($rules,$term,$nullable) = @_; + my(@nrules); + my($done); + + RULE: + for (@$rules) { + my($lhs,$rhs)=@$_; + + exists($$nullable{$lhs}) + and next; + + for (@$rhs) { + exists($$term{$_}) + and next RULE; + } + push(@nrules,[$lhs,$rhs]); + } + + do { + $done=1; + + RULE: + for (@nrules) { + my($lhs,$rhs)=@$_; + + exists($$nullable{$lhs}) + and next; + + for (@$rhs) { + exists($$nullable{$_}) + or next RULE; + } + $done=0; + ++$$nullable{$lhs}; + } + + }until($done); +} + +sub _ReduceGrammar { + my($values)=@_; + my($ufrules,$ufnterm,$reachable); + my($grammar)={ HEAD => $values->{HEAD}, + TAIL => $values->{TAIL}, + EXPECT => $values->{EXPECT} }; + my($rules,$nterm,$term) = @$values {'RULES', 'NTERM', 'TERM'}; + + ($ufrules,$ufnterm) = _UsefulRules($rules,$nterm); + + exists($$ufnterm{$values->{START}}) + or die "*Fatal* Start symbol $values->{START} derives nothing, at eof\n"; + + $reachable = _Reachable($rules,$nterm,$term,$ufrules,$ufnterm); + + $$grammar{TERM}{chr(0)}=undef; + for my $sym (keys %$term) { + ( exists($$reachable{$sym}) + or exists($values->{PREC}{$sym}) ) + and do { + $$grammar{TERM}{$sym} + = defined($$term{$sym}[0]) ? $$term{$sym} : undef; + next; + }; + push(@{$$grammar{UUTERM}},[ $sym, $values->{SYMS}{$sym} ]); + } + + $$grammar{NTERM}{'$start'}=[]; + for my $sym (keys %$nterm) { + exists($$reachable{$sym}) + and do { + exists($values->{NULL}{$sym}) + and ++$$grammar{NULLABLE}{$sym}; + $$grammar{NTERM}{$sym}=[]; + next; + }; + push(@{$$grammar{UUNTERM}},[ $sym, $values->{SYMS}{$sym} ]); + } + + for my $ruleno (0..$#$rules) { + vec($ufrules,$ruleno,1) + and exists($$grammar{NTERM}{$$rules[$ruleno][0]}) + and do { + push(@{$$grammar{RULES}},$$rules[$ruleno]); + push(@{$$grammar{NTERM}{$$rules[$ruleno][0]}},$#{$$grammar{RULES}}); + next; + }; + push(@{$$grammar{UURULES}},[ @{$$rules[$ruleno]}[0,1] ]); + } + + _SetNullable(@$grammar{'RULES', 'TERM', 'NULLABLE'}); + + $grammar; +}#_ReduceGrammar + +1; diff --git a/blib6/pugs/perl5/lib/Parse/Yapp/Lalr.pm b/blib6/pugs/perl5/lib/Parse/Yapp/Lalr.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Parse/Yapp/Lalr.pm @@ -0,0 +1,939 @@ +# +# Module Parse::Yapp::Lalr +# +# (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::Lalr; +@ISA=qw( Parse::Yapp::Grammar ); + +require 5.004; + +use Parse::Yapp::Grammar; + +=for nobody + +Parse::Yapp::Compile Object Structure: +-------------------------------------- +{ + GRAMMAR => Parse::Yapp::Grammar, + STATES => [ { CORE => [ items... ], + ACTIONS => { term => action } + GOTOS => { nterm => stateno } + }... ] + CONFLICTS=>{ SOLVED => { stateno => [ ruleno, token, solved ] }, + FORCED => { TOTAL => [ nbsr, nbrr ], + DETAIL => { stateno => { TOTAL => [ nbsr, nbrr ] } + LIST => [ ruleno, token ] + } + } + } +} + +'items' are of form: [ ruleno, dotpos ] +'term' in ACTIONS is '' means default action +'action' may be: + undef: explicit error (nonassociativity) + 0 : accept + >0 : shift and go to state 'action' + <0 : reduce using rule -'action' +'solved' may have values of: + 'shift' if solved as Shift + 'reduce' if solved as Reduce + 'error' if solved by discarding both Shift and Reduce (nonassoc) + +SOLVED is a set of states containing Solved conflicts +FORCED are forced conflict resolutions + +nbsr and nbrr are number of shift/reduce and reduce/reduce conflicts + +TOTAL is the total number of SR/RR conflicts for the parser + +DETAIL is the detail of conflicts for each state +TOTAL is the total number of SR/RR conflicts for a state +LIST is the list of discarded reductions (for display purpose only) + + +=cut + +use strict; + +use Carp; + +############### +# Constructor # +############### +sub new { + my($class)=shift; + + ref($class) + and $class=ref($class); + + my($self)=$class->SUPER::new(@_); + $self->_Compile(); + bless($self,$class); +} +########### +# Methods # +########### + +########################### +# Method To View Warnings # +########################### +sub Warnings { + my($self)=shift; + my($text); + my($nbsr,$nbrr)=@{$$self{CONFLICTS}{FORCED}{TOTAL}}; + + $text=$self->SUPER::Warnings(); + + $nbsr != $$self{GRAMMAR}{EXPECT} + and $text.="$nbsr shift/reduce conflict".($nbsr > 1 ? "s" : ""); + + $nbrr + and do { + $nbsr + and $text.=" and "; + $text.="$nbrr reduce/reduce conflict".($nbrr > 1 ? "s" : ""); + }; + + ( $nbsr != $$self{GRAMMAR}{EXPECT} + or $nbrr) + and $text.="\n"; + + $text; +} +############################# +# Method To View DFA States # +############################# +sub ShowDfa { + my($self)=shift; + my($text); + my($grammar,$states)=($$self{GRAMMAR}, $$self{STATES}); + + for my $stateno (0..$#$states) { + my(@shifts,@reduces,@errors,$default); + + $text.="State $stateno:\n\n"; + + #Dump Kernel Items + for (sort { $$a[0] <=> $$b[0] + or $$a[1] <=> $$b[1] } @{$$states[$stateno]{'CORE'}}) { + my($ruleno,$pos)=@$_; + my($lhs,$rhs)=@{$$grammar{RULES}[$ruleno]}[0,1]; + my(@rhscopy)=@$rhs; + + $ruleno + or $rhscopy[-1] = '$end'; + + splice(@rhscopy,$pos,0,'.'); + $text.= "\t$lhs -> ".join(' ',@rhscopy)."\t(Rule $ruleno)\n"; + } + + #Prepare Actions + for (keys(%{$$states[$stateno]{ACTIONS}})) { + my($term,$action)=($_,$$states[$stateno]{ACTIONS}{$_}); + + $term eq chr(0) + and $term = '$end'; + + not defined($action) + and do { + push(@errors,$term); + next; + }; + + $action > 0 + and do { + push(@shifts,[ $term, $action ]); + next; + }; + + $action = -$action; + + $term + or do { + $default= [ '$default', $action ]; + next; + }; + + push(@reduces,[ $term, $action ]); + } + + #Dump shifts + @shifts + and do { + $text.="\n"; + for (sort { $$a[0] cmp $$b[0] } @shifts) { + my($term,$shift)=@$_; + + $text.="\t$term\tshift, and go to state $shift\n"; + } + }; + + #Dump errors + @errors + and do { + $text.="\n"; + for my $term (sort { $a cmp $b } @errors) { + $text.="\t$term\terror (nonassociative)\n"; + } + }; + + #Prepare reduces + exists($$self{CONFLICTS}{FORCED}{DETAIL}{$stateno}) + and push(@reduces,@{$$self{CONFLICTS}{FORCED}{DETAIL}{$stateno}{LIST}}); + + @reduces=sort { $$a[0] cmp $$b[0] or $$a[1] <=> $$b[1] } @reduces; + + defined($default) + and push(@reduces,$default); + + #Dump reduces + @reduces + and do { + $text.="\n"; + for (@reduces) { + my($term,$ruleno)=@$_; + my($discard); + + $ruleno < 0 + and do { + ++$discard; + $ruleno = -$ruleno; + }; + + $text.= "\t$term\t".($discard ? "[" : ""); + if($ruleno) { + $text.= "reduce using rule $ruleno ". + "($$grammar{RULES}[$ruleno][0])"; + } + else { + $text.='accept'; + } + $text.=($discard ? "]" : "")."\n"; + } + }; + + #Dump gotos + exists($$states[$stateno]{GOTOS}) + and do { + $text.= "\n"; + for (keys(%{$$states[$stateno]{GOTOS}})) { + $text.= "\t$_\tgo to state $$states[$stateno]{GOTOS}{$_}\n"; + } + }; + + $text.="\n"; + } + $text; +} + +###################################### +# Method to get summary about parser # +###################################### +sub Summary { + my($self)=shift; + my($text); + + $text=$self->SUPER::Summary(); + $text.="Number of states : ". + scalar(@{$$self{STATES}})."\n"; + $text; +} + +####################################### +# Method To Get Infos about conflicts # +####################################### +sub Conflicts { + my($self)=shift; + my($states)=$$self{STATES}; + my($conflicts)=$$self{CONFLICTS}; + my($text); + + for my $stateno ( sort { $a <=> $b } keys(%{$$conflicts{SOLVED}})) { + + for (@{$$conflicts{SOLVED}{$stateno}}) { + my($ruleno,$token,$how)=@$_; + + $token eq chr(0) + and $token = '$end'; + + $text.="Conflict in state $stateno between rule ". + "$ruleno and token $token resolved as $how.\n"; + } + }; + + for my $stateno ( sort { $a <=> $b } keys(%{$$conflicts{FORCED}{DETAIL}})) { + my($nbsr,$nbrr)=@{$$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}}; + + $text.="State $stateno contains "; + + $nbsr + and $text.="$nbsr shift/reduce conflict". + ($nbsr > 1 ? "s" : ""); + + $nbrr + and do { + $nbsr + and $text.=" and "; + + $text.="$nbrr reduce/reduce conflict". + ($nbrr > 1 ? "s" : ""); + }; + $text.="\n"; + }; + + $text; +} + +################################# +# Method to dump parsing tables # +################################# +sub DfaTable { + my($self)=shift; + my($states)=$$self{STATES}; + my($stateno); + my($text); + + $text="[\n\t{"; + + $text.=join("\n\t},\n\t{", + map { + my($state)=$_; + my($text); + + $text="#State ".$stateno++."\n\t\t"; + + ( not exists($$state{ACTIONS}{''}) + or keys(%{$$state{ACTIONS}}) > 1) + and do { + + $text.="ACTIONS => {\n\t\t\t"; + + $text.=join(",\n\t\t\t", + map { + my($term,$action)=($_,$$state{ACTIONS}{$_}); + my($text); + + if(substr($term,0,1) eq "'") { + $term=~s/([\@\$\"])/\\$1/g; + $term=~s/^'|'$/"/g; + } + else { + $term= $term eq chr(0) + ? "''" + : "'$term'"; + } + + if(defined($action)) { + $action=int($action); + } + else { + $action='undef'; + } + + "$term => $action"; + + } grep { $_ } keys(%{$$state{ACTIONS}})); + + $text.="\n\t\t}"; + }; + + exists($$state{ACTIONS}{''}) + and do { + keys(%{$$state{ACTIONS}}) > 1 + and $text.=",\n\t\t"; + + $text.="DEFAULT => $$state{ACTIONS}{''}"; + }; + + exists($$state{GOTOS}) + and do { + $text.=",\n\t\tGOTOS => {\n\t\t\t"; + $text.=join(",\n\t\t\t", + map { + my($nterm,$stateno)=($_,$$state{GOTOS}{$_}); + my($text); + + "'$nterm' => $stateno"; + + } keys(%{$$state{GOTOS}})); + $text.="\n\t\t}"; + }; + + $text; + + }@$states); + + $text.="\n\t}\n]"; + + $text; + +} + + +#################################### +# Method to build Dfa from Grammar # +#################################### +sub _Compile { + my($self)=shift; + my($grammar,$states); + + $grammar=$self->{GRAMMAR}; + + $states = _LR0($grammar); + + $self->{CONFLICTS} = _LALR($grammar,$states); + + $self->{STATES}=$states; +} + +######################### +# LR0 States Generation # +######################### +# +########################### +# General digraph routine # +########################### +sub _Digraph { + my($rel,$F)=@_; + my(%N,@S); + my($infinity)=(~(1<<31)); + my($Traverse); + + $Traverse = sub { + my($x,$d)=@_; + my($y); + + push(@S,$x); + $N{$x}=$d; + + exists($$rel{$x}) + and do { + for $y (keys(%{$$rel{$x}})) { + exists($N{$y}) + or &$Traverse($y,$d+1); + + $N{$y} < $N{$x} + and $N{$x} = $N{$y}; + + $$F{$x}|=$$F{$y}; + } + }; + + $N{$x} == $d + and do { + for(;;) { + $y=pop(@S); + $N{$y}=$infinity; + $y eq $x + and last; + $$F{$y}=$$F{$x}; + } + }; + }; + + for (keys(%$rel)) { + exists($N{$_}) + or &$Traverse($_,1); + } +} +####################### +# Generate LR0 states # +####################### +=for nobody +Formula used for closures: + + CLOSE(A) = DCLOSE(A) u U (CLOSE(B) | A close B) + +where: + + DCLOSE(A) = { [ A -> alpha ] in P } + + A close B iff [ A -> B gamma ] in P + +=cut +sub _SetClosures { + my($grammar)=@_; + my($rel,$closures); + + for my $symbol (keys(%{$$grammar{NTERM}})) { + $closures->{$symbol}=pack('b'.@{$$grammar{RULES}}); + + for my $ruleno (@{$$grammar{NTERM}{$symbol}}) { + my($rhs)=$$grammar{RULES}[$ruleno][1]; + + vec($closures->{$symbol},$ruleno,1)=1; + + @$rhs > 0 + and exists($$grammar{NTERM}{$$rhs[0]}) + and ++$rel->{$symbol}{$$rhs[0]}; + } + } + _Digraph($rel,$closures); + + $closures +} + +sub _Closures { + my($grammar,$core,$closures)=@_; + my($ruleset)=pack('b'.@{$$grammar{RULES}}); + + for (@$core) { + my($ruleno,$pos)=@$_; + my($rhs)=$$grammar{RULES}[$ruleno][1]; + + $pos < @$rhs + and exists($closures->{$$rhs[$pos]}) + and $ruleset|=$closures->{$$rhs[$pos]}; + } + [ @$core, map { [ $_, 0 ] } + grep { vec($ruleset,$_,1) } + 0..$#{$$grammar{RULES}} ]; +} + +sub _Transitions { + my($grammar,$cores,$closures,$states,$stateno)=@_; + my($core)=$$states[$stateno]{'CORE'}; + my(%transitions); + + for (@{_Closures($grammar,$core,$closures)}) { + my($ruleno,$pos)=@$_; + my($rhs)=$$grammar{RULES}[$ruleno][1]; + + $pos == @$rhs + and do { + push(@{$$states[$stateno]{ACTIONS}{''}},$ruleno); + next; + }; + push(@{$transitions{$$rhs[$pos]}},[ $ruleno, $pos+1 ]); + } + + for (keys(%transitions)) { + my($symbol,$core)=($_,$transitions{$_}); + my($corekey)=join(',',map { join('.',@$_) } + sort { $$a[0] <=> $$b[0] + or $$a[1] <=> $$b[1] } + @$core); + my($tostateno); + + exists($cores->{$corekey}) + or do { + push(@$states,{ 'CORE' => $core }); + $cores->{$corekey}=$#$states; + }; + + $tostateno=$cores->{$corekey}; + push(@{$$states[$tostateno]{FROM}},$stateno); + + exists($$grammar{TERM}{$_}) + and do { + $$states[$stateno]{ACTIONS}{$_} = [ $tostateno ]; + next; + }; + $$states[$stateno]{GOTOS}{$_} = $tostateno; + } +} + +sub _LR0 { + my($grammar)=@_; + my($states) = []; + my($stateno); + my($closures); #$closures={ nterm => ruleset,... } + my($cores)={}; # { "itemlist" => stateno, ... } + # where "itemlist" has the form: + # "ruleno.pos,ruleno.pos" ordered by ruleno,pos + + $closures = _SetClosures($grammar); + push(@$states,{ 'CORE' => [ [ 0, 0 ] ] }); + for($stateno=0;$stateno<@$states;++$stateno) { + _Transitions($grammar,$cores,$closures,$states,$stateno); + } + + $states +} + +######################################################### +# Add Lookahead tokens where needed to make LALR states # +######################################################### +=for nobody + Compute First sets for non-terminal using the following formula: + + FIRST(A) = { a in T u { epsilon } | A l a } + u + U { FIRST(B) | B in V and A l B } + + where: + + A l x iff [ A -> X1 X2 .. Xn x alpha ] in P and Xi =>* epsilon, 1 <= i <= n +=cut +sub _SetFirst { + my($grammar,$termlst,$terminx)=@_; + my($rel,$first)=( {}, {} ); + + for my $symbol (keys(%{$$grammar{NTERM}})) { + $first->{$symbol}=pack('b'.@$termlst); + + RULE: + for my $ruleno (@{$$grammar{NTERM}{$symbol}}) { + my($rhs)=$$grammar{RULES}[$ruleno][1]; + + for (@$rhs) { + exists($terminx->{$_}) + and do { + vec($first->{$symbol},$terminx->{$_},1)=1; + next RULE; + }; + ++$rel->{$symbol}{$_}; + exists($$grammar{NULLABLE}{$_}) + or next RULE; + } + vec($first->{$symbol},0,1)=1; + } + } + _Digraph($rel,$first); + + $first +} + +sub _Preds { + my($states,$stateno,$len)=@_; + my($queue, $preds); + + $len + or return [ $stateno ]; + + $queue=[ [ $stateno, $len ] ]; + while(@$queue) { + my($pred) = shift(@$queue); + my($stateno, $len) = @$pred; + + $len == 1 + and do { + push(@$preds,@{$states->[$stateno]{FROM}}); + next; + }; + + push(@$queue, map { [ $_, $len - 1 ] } + @{$states->[$stateno]{FROM}}); + } + + # Pass @$preds through a hash to ensure unicity + [ keys( %{ +{ map { ($_,1) } @$preds } } ) ]; +} + +sub _FirstSfx { + my($grammar,$firstset,$termlst,$terminx,$ruleno,$pos,$key)=@_; + my($first)=pack('b'.@$termlst); + my($rhs)=$$grammar{RULES}[$ruleno][1]; + + for (;$pos < @$rhs;++$pos) { + exists($terminx->{$$rhs[$pos]}) + and do { + vec($first,$terminx->{$$rhs[$pos]},1)=1; + return($first); + }; + $first|=$firstset->{$$rhs[$pos]}; + + vec($first,0,1) + and vec($first,0,1)=0; + + exists($$grammar{NULLABLE}{$$rhs[$pos]}) + or return($first); + + } + vec($first,0,1)=1; + $first; +} + +=for noboby + Compute Follow sets using following formula: + + FOLLOW(p,A) = READ(p,A) + u + U { FOLLOW(q,B) | (p,A) include (q,B) + + where: + + READ(p,A) = U { FIRST(beta) | [ A -> alpha A . beta ] in KERNEL(GOTO(p,A)) + } - { epsilon } + + (p,a) include (q,B) iff [ B -> alpha A . beta ] in KERNEL(GOTO(p,A), + epsilon in FIRST(beta) and + q in PRED(p,alpha) +=cut +sub _ComputeFollows { + my($grammar,$states,$termlst)=@_; + my($firstset,$terminx); + my($inconsistent, $rel, $follows, $sfx)= ( {}, {}, {}, {} ); + + %$terminx= map { ($termlst->[$_],$_) } 0..$#$termlst; + + $firstset=_SetFirst($grammar,$termlst,$terminx); + + for my $stateno (0..$#$states) { + my($state)=$$states[$stateno]; + + exists($$state{ACTIONS}{''}) + and ( @{$$state{ACTIONS}{''}} > 1 + or keys(%{$$state{ACTIONS}}) > 1 ) + and do { + ++$inconsistent->{$stateno}; + + for my $ruleno (@{$$state{ACTIONS}{''}}) { + my($lhs,$rhs)=@{$$grammar{RULES}[$ruleno]}[0,1]; + + for my $predno (@{_Preds($states,$stateno,scalar(@$rhs))}) { + ++$rel->{"$stateno.$ruleno"}{"$predno.$lhs"}; + } + } + }; + + exists($$state{GOTOS}) + or next; + + for my $symbol (keys(%{$$state{GOTOS}})) { + my($tostate)=$$states[$$state{GOTOS}{$symbol}]; + my($goto)="$stateno.$symbol"; + + $follows->{$goto}=pack('b'.@$termlst); + + for my $item (@{$$tostate{'CORE'}}) { + my($ruleno,$pos)=@$item; + my($key)="$ruleno.$pos"; + + exists($sfx->{$key}) + or $sfx->{$key} = _FirstSfx($grammar,$firstset, + $termlst,$terminx, + $ruleno,$pos,$key); + + $follows->{$goto}|=$sfx->{$key}; + + vec($follows->{$goto},0,1) + and do { + my($lhs)=$$grammar{RULES}[$ruleno][0]; + + vec($follows->{$goto},0,1)=0; + + for my $predno (@{_Preds($states,$stateno,$pos-1)}) { + ++$rel->{$goto}{"$predno.$lhs"}; + } + }; + } + } + } + _Digraph($rel,$follows); + + ($follows,$inconsistent) +} + +sub _ComputeLA { + my($grammar,$states)=@_; + my($termlst)= [ '',keys(%{$$grammar{TERM}}) ]; + + my($follows,$inconsistent) = _ComputeFollows($grammar,$states,$termlst); + + for my $stateno ( keys(%$inconsistent ) ) { + my($state)=$$states[$stateno]; + my($conflict); + + #NB the sort is VERY important for conflicts resolution order + for my $ruleno (sort { $a <=> $b } + @{$$state{ACTIONS}{''}}) { + for my $term ( map { $termlst->[$_] } grep { + vec($follows->{"$stateno.$ruleno"},$_,1) } + 0..$#$termlst) { + exists($$state{ACTIONS}{$term}) + and ++$conflict; + push(@{$$state{ACTIONS}{$term}},-$ruleno); + } + } + delete($$state{ACTIONS}{''}); + $conflict + or delete($inconsistent->{$stateno}); + } + + $inconsistent +} + +############################# +# Solve remaining conflicts # +############################# + +sub _SolveConflicts { + my($grammar,$states,$inconsistent)=@_; + my(%rulesprec,$RulePrec); + my($conflicts)={ SOLVED => {}, + FORCED => { TOTAL => [ 0, 0 ], + DETAIL => {} + } + }; + + $RulePrec = sub { + my($ruleno)=@_; + my($rhs,$rprec)=@{$$grammar{RULES}[$ruleno]}[1,2]; + my($lastterm); + + defined($rprec) + and return($rprec); + + exists($rulesprec{$ruleno}) + and return($rulesprec{$ruleno}); + + $lastterm=(grep { exists($$grammar{TERM}{$_}) } @$rhs)[-1]; + + defined($lastterm) + and ref($$grammar{TERM}{$lastterm}) + and do { + $rulesprec{$ruleno}=$$grammar{TERM}{$lastterm}[1]; + return($rulesprec{$ruleno}); + }; + + undef; + }; + + for my $stateno (keys(%$inconsistent)) { + my($state)=$$states[$stateno]; + my($actions)=$$state{ACTIONS}; + my($nbsr,$nbrr); + + for my $term ( keys(%$actions) ) { + my($act)=$$actions{$term}; + + @$act > 1 + or next; + + $$act[0] > 0 + and ref($$grammar{TERM}{$term}) + and do { + my($assoc,$tprec)=@{$$grammar{TERM}{$term}}; + my($k,$error); + + for ($k=1;$k<@$act;++$k) { + my($ruleno)=-$$act[$k]; + my($rprec)=&$RulePrec($ruleno); + + defined($rprec) + or next; + + ( $tprec > $rprec + or ( $tprec == $rprec and $assoc eq 'RIGHT')) + and do { + push(@{$$conflicts{SOLVED}{$stateno}}, + [ $ruleno, $term, 'shift' ]); + splice(@$act,$k--,1); + next; + }; + ( $tprec < $rprec + or $assoc eq 'LEFT') + and do { + push(@{$$conflicts{SOLVED}{$stateno}}, + [ $ruleno, $term, 'reduce' ]); + $$act[0] > 0 + and do { + splice(@$act,0,1); + --$k; + }; + next; + }; + push(@{$$conflicts{SOLVED}{$stateno}}, + [ $ruleno, $term, 'error' ]); + splice(@$act,$k--,1); + $$act[0] > 0 + and do { + splice(@$act,0,1); + ++$error; + --$k; + }; + } + $error + and unshift(@$act,undef); + }; + + @$act > 1 + and do { + $nbrr += @$act - 2; + ($$act[0] > 0 ? $nbsr : $nbrr) += 1; + push(@{$$conflicts{FORCED}{DETAIL}{$stateno}{LIST}}, + map { [ $term, $_ ] } splice(@$act,1)); + }; + } + + $nbsr + and do { + $$conflicts{FORCED}{TOTAL}[0]+=$nbsr; + $$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}[0]+=$nbsr; + }; + + $nbrr + and do { + $$conflicts{FORCED}{TOTAL}[1]+=$nbrr; + $$conflicts{FORCED}{DETAIL}{$stateno}{TOTAL}[1]+=$nbrr; + }; + + } + + $conflicts +} + +############################### +# Make default reduce actions # +############################### +sub _SetDefaults { + my($states)=@_; + + for my $state (@$states) { + my($actions)=$$state{ACTIONS}; + my(%reduces,$default,$nodefault); + + exists($$actions{''}) + and do { + $$actions{''}[0] = -$$actions{''}[0]; + ++$nodefault; + }; + + #shift error token => no default + exists($$actions{error}) + and $$actions{error}[0] > 0 + and ++$nodefault; + + for my $term (keys(%$actions)) { + + $$actions{$term}=$$actions{$term}[0]; + + ( not defined($$actions{$term}) + or $$actions{$term} > 0 + or $nodefault) + and next; + + push(@{$reduces{$$actions{$term}}},$term); + } + + keys(%reduces) > 0 + or next; + + $default=( map { $$_[0] } + sort { $$b[1] <=> $$a[1] or $$b[0] <=> $$a[0] } + map { [ $_, scalar(@{$reduces{$_}}) ] } + keys(%reduces))[0]; + + delete(@$actions{ @{$reduces{$default}} }); + $$state{ACTIONS}{''}=$default; + } +} + +sub _LALR { + my($grammar,$states) = @_; + my($conflicts,$inconsistent); + + $inconsistent = _ComputeLA($grammar,$states); + + $conflicts = _SolveConflicts($grammar,$states,$inconsistent); + _SetDefaults($states); + + $conflicts +} + + +1; diff --git a/blib6/pugs/perl5/lib/Parse/Yapp/Options.pm b/blib6/pugs/perl5/lib/Parse/Yapp/Options.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Parse/Yapp/Options.pm @@ -0,0 +1,186 @@ +# +# Module Parse::Yapp::Options +# +# (c) Copyright 1999-2001 Francois Desarmenien, all rights reserved. +# (see the pod text in Parse::Yapp module for use and distribution rights) +# +package Parse::Yapp::Options; + +use strict; +use Carp; + +############################################################################ +#Definitions of options +# +# %known_options allowed options +# +# %default_options default +# +# %actions sub refs to execute if option is set with ($self,$value) +# as parameters +############################################################################ +# +#A value of '' means any value can do +# +my(%known_options)= ( + language => { + perl => "Ouput parser for Perl language", +# for future use... +# 'c++' => "Output parser for C++ language", +# c => "Output parser for C language" + }, + linenumbers => { + 0 => "Don't embbed line numbers in parser", + 1 => "Embbed source line numbers in parser" + }, + inputfile => { + '' => "Input file name: will automagically fills input" + }, + classname => { + '' => "Class name of parser object (Perl and C++)" + }, + standalone => { + 0 => "Don't create a standalone parser (Perl and C++)", + 1 => "Create a standalone parser" + }, + input => { + '' => "Input text of grammar" + }, + template => { + '' => "Template text for generating grammar file" + }, +); + +my(%default_options)= ( + language => 'perl', + linenumbers => 1, + inputfile => undef, + classname => 'Parser', + standalone => 0, + input => undef, + template => undef, + shebang => undef, +); + +my(%actions)= ( + inputfile => \&__LoadFile +); + +############################################################################# +# +# Actions +# +# These are NOT a method, although they look like... +# +# They are super-private routines (that's why I prepend __ to their names) +# +############################################################################# +sub __LoadFile { + my($self,$filename)=@_; + + open(IN,"<$filename") + or croak "Cannot open input file '$filename' for reading"; + $self->{OPTIONS}{input}=join('',); + close(IN); +} + +############################################################################# +# +# Private methods +# +############################################################################# + +sub _SetOption { + my($self)=shift; + my($key,$value)=@_; + + $key=lc($key); + + @_ == 2 + or croak "Invalid number of arguments"; + + exists($known_options{$key}) + or croak "Unknown option: '$key'"; + + if(exists($known_options{$key}{lc($value)})) { + $value=lc($value); + } + elsif(not exists($known_options{$key}{''})) { + croak "Invalid value '$value' for option '$key'"; + } + + exists($actions{$key}) + and &{$actions{$key}}($self,$value); + + $self->{OPTIONS}{$key}=$value; +} + +sub _GetOption { + my($self)=shift; + my($key)=map { lc($_) } @_; + + @_ == 1 + or croak "Invalid number of arguments"; + + exists($known_options{$key}) + or croak "Unknown option: '$key'"; + + $self->{OPTIONS}{$key}; +} + +############################################################################# +# +# Public methods +# +############################################################################# + +# +# Constructor +# +sub new { + my($class)=shift; + my($self)={ OPTIONS => { %default_options } }; + + ref($class) + and $class=ref($class); + + bless($self,$class); + + $self->Options(@_); + + $self; +} + +# +# Specify one or more options to set +# +sub Options { + my($self)=shift; + my($key,$value); + + @_ % 2 == 0 + or croak "Invalid number of arguments"; + + while(($key,$value)=splice(@_,0,2)) { + $self->_SetOption($key,$value); + } +} + +# +# Set (2 parameters) or Get (1 parameter) values for one option +# +sub Option { + my($self)=shift; + my($key,$value)=@_; + + @_ == 1 + and return $self->_GetOption($key); + + @_ == 2 + and return $self->_SetOption($key,$value); + + croak "Invalid number of arguments"; + +} + +1; diff --git a/blib6/pugs/perl5/lib/Parse/Yapp/Output.pm b/blib6/pugs/perl5/lib/Parse/Yapp/Output.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Parse/Yapp/Output.pm @@ -0,0 +1,92 @@ +# +# Module Parse::Yapp::Output +# +# (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::Output; +@ISA=qw ( Parse::Yapp::Lalr ); + +require 5.004; + +use Parse::Yapp::Lalr; +use Parse::Yapp::Driver; + +use strict; + +use Carp; + +sub _CopyDriver { + my($text)='#Included Parse/Yapp/Driver.pm file'.('-' x 40)."\n"; + open(DRV,$Parse::Yapp::Driver::FILENAME) + or die "BUG: could not open $Parse::Yapp::Driver::FILENAME"; + $text.="{\n".join('',)."}\n"; + close(DRV); + $text.='#End of include'.('-' x 50)."\n"; +} + +sub Output { + my($self)=shift; + + $self->Options(@_); + + my($package)=$self->Option('classname'); + my($head,$states,$rules,$tail,$driver); + my($version)=$Parse::Yapp::Driver::VERSION; + my($datapos); + my($text)=$self->Option('template') ||<<'EOT'; +#################################################################### +# +# This file was generated using Parse::Yapp version <<$version>>. +# +# Don't edit this file, use source file instead. +# +# ANY CHANGE MADE HERE WILL BE LOST ! +# +#################################################################### +package <<$package>>; +use vars qw ( @ISA ); +use strict; + +@ISA= qw ( Parse::Yapp::Driver ); +<<$driver>> + +<<$head>> + +sub new { + my($class)=shift; + ref($class) + and $class=ref($class); + + my($self)=$class->SUPER::new( yyversion => '<<$version>>', + yystates => +<<$states>>, + yyrules => +<<$rules>>, + @_); + bless($self,$class); +} + +<<$tail>> +1; +EOT + + $driver='use Parse::Yapp::Driver;'; + + defined($package) + or $package='Parse::Yapp::Default'; + + $head= $self->Head(); + $rules=$self->RulesTable(); + $states=$self->DfaTable(); + $tail= $self->Tail(); + + $self->Option('standalone') + and $driver=_CopyDriver(); + + $text=~s/<<(\$.+)>>/$1/gee; + + $text; +} + +1; diff --git a/blib6/pugs/perl5/lib/Parse/Yapp/Parse.pm b/blib6/pugs/perl5/lib/Parse/Yapp/Parse.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Parse/Yapp/Parse.pm @@ -0,0 +1,1093 @@ +#################################################################### +# +# This file was generated using Parse::Yapp version 1.05. +# +# Don't edit this file, use source file instead. +# +# ANY CHANGE MADE HERE WILL BE LOST ! +# +#################################################################### +package Parse::Yapp::Parse; +use vars qw ( @ISA ); +use strict; + +@ISA= qw ( Parse::Yapp::Driver ); +use Parse::Yapp::Driver; + +#line 1 "YappParse.yp" +# (c) Copyright Francois Desarmenien 1998-2001, all rights reserved. +# (see COPYRIGHT in Parse::Yapp.pm pod section for use and distribution rights) +# +# Parse/Yapp/Parser.yp: Parse::Yapp::Parser.pm source file +# +# Use: yapp -m 'Parse::Yapp::Parse' -o Parse/Yapp/Parse.pm YappParse.yp +# +# to generate the Parser module. +# +#line 12 "YappParse.yp" + +require 5.004; + +use Carp; + +my($input,$lexlevel,@lineno,$nberr,$prec,$labelno); +my($syms,$head,$tail,$token,$term,$nterm,$rules,$precterm,$start,$nullable); +my($expect); + + + +sub new { + my($class)=shift; + ref($class) + and $class=ref($class); + + my($self)=$class->SUPER::new( yyversion => '1.05', + yystates => +[ + {#State 0 + ACTIONS => { + "%%" => -6, + 'HEADCODE' => 3, + 'UNION' => 2, + 'TOKEN' => 5, + 'ASSOC' => 7, + 'START' => 6, + 'error' => 9, + 'TYPE' => 10, + "\n" => 11, + 'EXPECT' => 13 + }, + GOTOS => { + 'head' => 1, + 'decls' => 12, + 'yapp' => 4, + 'decl' => 14, + 'headsec' => 8 + } + }, + {#State 1 + ACTIONS => { + 'error' => 19, + "%%" => 16, + 'IDENT' => 18 + }, + GOTOS => { + 'rules' => 15, + 'rulesec' => 20, + 'body' => 17 + } + }, + {#State 2 + ACTIONS => { + 'CODE' => 21 + } + }, + {#State 3 + ACTIONS => { + "\n" => 22 + } + }, + {#State 4 + ACTIONS => { + '' => 23 + } + }, + {#State 5 + ACTIONS => { + "<" => 25 + }, + DEFAULT => -19, + GOTOS => { + 'typedecl' => 24 + } + }, + {#State 6 + ACTIONS => { + 'IDENT' => 26 + }, + GOTOS => { + 'ident' => 27 + } + }, + {#State 7 + ACTIONS => { + "<" => 25 + }, + DEFAULT => -19, + GOTOS => { + 'typedecl' => 28 + } + }, + {#State 8 + ACTIONS => { + "%%" => 29 + } + }, + {#State 9 + ACTIONS => { + "\n" => 30 + } + }, + {#State 10 + ACTIONS => { + "<" => 25 + }, + DEFAULT => -19, + GOTOS => { + 'typedecl' => 31 + } + }, + {#State 11 + DEFAULT => -10 + }, + {#State 12 + ACTIONS => { + "%%" => -7, + 'HEADCODE' => 3, + 'UNION' => 2, + 'TOKEN' => 5, + 'ASSOC' => 7, + 'START' => 6, + 'error' => 9, + 'TYPE' => 10, + "\n" => 11, + 'EXPECT' => 13 + }, + GOTOS => { + 'decl' => 32 + } + }, + {#State 13 + ACTIONS => { + 'NUMBER' => 33 + } + }, + {#State 14 + DEFAULT => -9 + }, + {#State 15 + DEFAULT => -28 + }, + {#State 16 + DEFAULT => -26 + }, + {#State 17 + ACTIONS => { + 'TAILCODE' => 34 + }, + DEFAULT => -45, + GOTOS => { + 'tail' => 35 + } + }, + {#State 18 + ACTIONS => { + ":" => 36 + } + }, + {#State 19 + ACTIONS => { + ";" => 37 + } + }, + {#State 20 + ACTIONS => { + 'error' => 19, + "%%" => 39, + 'IDENT' => 18 + }, + GOTOS => { + 'rules' => 38 + } + }, + {#State 21 + ACTIONS => { + "\n" => 40 + } + }, + {#State 22 + DEFAULT => -14 + }, + {#State 23 + DEFAULT => -0 + }, + {#State 24 + ACTIONS => { + 'LITERAL' => 41, + 'IDENT' => 26 + }, + GOTOS => { + 'symlist' => 43, + 'ident' => 44, + 'symbol' => 42 + } + }, + {#State 25 + ACTIONS => { + 'IDENT' => 45 + } + }, + {#State 26 + DEFAULT => -4 + }, + {#State 27 + ACTIONS => { + "\n" => 46 + } + }, + {#State 28 + ACTIONS => { + 'LITERAL' => 41, + 'IDENT' => 26 + }, + GOTOS => { + 'symlist' => 47, + 'ident' => 44, + 'symbol' => 42 + } + }, + {#State 29 + DEFAULT => -5 + }, + {#State 30 + DEFAULT => -18 + }, + {#State 31 + ACTIONS => { + 'IDENT' => 26 + }, + GOTOS => { + 'ident' => 48, + 'identlist' => 49 + } + }, + {#State 32 + DEFAULT => -8 + }, + {#State 33 + ACTIONS => { + "\n" => 50 + } + }, + {#State 34 + DEFAULT => -46 + }, + {#State 35 + DEFAULT => -1 + }, + {#State 36 + ACTIONS => { + 'CODE' => 57, + 'LITERAL' => 41, + 'IDENT' => 26 + }, + DEFAULT => -35, + GOTOS => { + 'rhselts' => 56, + 'rule' => 51, + 'code' => 52, + 'rhs' => 53, + 'ident' => 44, + 'rhselt' => 58, + 'rhss' => 55, + 'symbol' => 54 + } + }, + {#State 37 + DEFAULT => -30 + }, + {#State 38 + DEFAULT => -27 + }, + {#State 39 + DEFAULT => -25 + }, + {#State 40 + DEFAULT => -15 + }, + {#State 41 + DEFAULT => -2 + }, + {#State 42 + DEFAULT => -22 + }, + {#State 43 + ACTIONS => { + "\n" => 60, + 'LITERAL' => 41, + 'IDENT' => 26 + }, + GOTOS => { + 'ident' => 44, + 'symbol' => 59 + } + }, + {#State 44 + DEFAULT => -3 + }, + {#State 45 + ACTIONS => { + ">" => 61 + } + }, + {#State 46 + DEFAULT => -13 + }, + {#State 47 + ACTIONS => { + "\n" => 62, + 'LITERAL' => 41, + 'IDENT' => 26 + }, + GOTOS => { + 'ident' => 44, + 'symbol' => 59 + } + }, + {#State 48 + DEFAULT => -24 + }, + {#State 49 + ACTIONS => { + "\n" => 63, + 'IDENT' => 26 + }, + GOTOS => { + 'ident' => 64 + } + }, + {#State 50 + DEFAULT => -17 + }, + {#State 51 + DEFAULT => -32 + }, + {#State 52 + DEFAULT => -40 + }, + {#State 53 + ACTIONS => { + 'PREC' => 66 + }, + DEFAULT => -34, + GOTOS => { + 'prec' => 65 + } + }, + {#State 54 + DEFAULT => -39 + }, + {#State 55 + ACTIONS => { + "|" => 68, + ";" => 67 + } + }, + {#State 56 + ACTIONS => { + 'CODE' => 57, + 'LITERAL' => 41, + 'IDENT' => 26 + }, + DEFAULT => -36, + GOTOS => { + 'code' => 52, + 'ident' => 44, + 'rhselt' => 69, + 'symbol' => 54 + } + }, + {#State 57 + DEFAULT => -44 + }, + {#State 58 + DEFAULT => -38 + }, + {#State 59 + DEFAULT => -21 + }, + {#State 60 + DEFAULT => -11 + }, + {#State 61 + DEFAULT => -20 + }, + {#State 62 + DEFAULT => -12 + }, + {#State 63 + DEFAULT => -16 + }, + {#State 64 + DEFAULT => -23 + }, + {#State 65 + ACTIONS => { + 'CODE' => 57 + }, + DEFAULT => -42, + GOTOS => { + 'code' => 70, + 'epscode' => 71 + } + }, + {#State 66 + ACTIONS => { + 'LITERAL' => 41, + 'IDENT' => 26 + }, + GOTOS => { + 'ident' => 44, + 'symbol' => 72 + } + }, + {#State 67 + DEFAULT => -29 + }, + {#State 68 + ACTIONS => { + 'CODE' => 57, + 'LITERAL' => 41, + 'IDENT' => 26 + }, + DEFAULT => -35, + GOTOS => { + 'rhselts' => 56, + 'rule' => 73, + 'code' => 52, + 'rhs' => 53, + 'ident' => 44, + 'rhselt' => 58, + 'symbol' => 54 + } + }, + {#State 69 + DEFAULT => -37 + }, + {#State 70 + DEFAULT => -43 + }, + {#State 71 + DEFAULT => -33 + }, + {#State 72 + DEFAULT => -41 + }, + {#State 73 + DEFAULT => -31 + } +], + yyrules => +[ + [#Rule 0 + '$start', 2, undef + ], + [#Rule 1 + 'yapp', 3, undef + ], + [#Rule 2 + 'symbol', 1, +sub +#line 30 "YappParse.yp" +{ + exists($$syms{$_[1][0]}) + or do { + $$syms{$_[1][0]} = $_[1][1]; + $$term{$_[1][0]} = undef; + }; + $_[1] + } + ], + [#Rule 3 + 'symbol', 1, undef + ], + [#Rule 4 + 'ident', 1, +sub +#line 41 "YappParse.yp" +{ + exists($$syms{$_[1][0]}) + or do { + $$syms{$_[1][0]} = $_[1][1]; + $$term{$_[1][0]} = undef; + }; + $_[1] + } + ], + [#Rule 5 + 'head', 2, undef + ], + [#Rule 6 + 'headsec', 0, undef + ], + [#Rule 7 + 'headsec', 1, undef + ], + [#Rule 8 + 'decls', 2, undef + ], + [#Rule 9 + 'decls', 1, undef + ], + [#Rule 10 + 'decl', 1, undef + ], + [#Rule 11 + 'decl', 4, +sub +#line 66 "YappParse.yp" +{ + for (@{$_[3]}) { + my($symbol,$lineno)=@$_; + + exists($$token{$symbol}) + and do { + _SyntaxError(0, + "Token $symbol redefined: ". + "Previously defined line $$syms{$symbol}", + $lineno); + next; + }; + $$token{$symbol}=$lineno; + $$term{$symbol} = [ ]; + } + undef + } + ], + [#Rule 12 + 'decl', 4, +sub +#line 84 "YappParse.yp" +{ + for (@{$_[3]}) { + my($symbol,$lineno)=@$_; + + defined($$term{$symbol}[0]) + and do { + _SyntaxError(1, + "Precedence for symbol $symbol redefined: ". + "Previously defined line $$syms{$symbol}", + $lineno); + next; + }; + $$token{$symbol}=$lineno; + $$term{$symbol} = [ $_[1][0], $prec ]; + } + ++$prec; + undef + } + ], + [#Rule 13 + 'decl', 3, +sub +#line 102 "YappParse.yp" +{ $start=$_[2][0]; undef } + ], + [#Rule 14 + 'decl', 2, +sub +#line 103 "YappParse.yp" +{ push(@$head,$_[1]); undef } + ], + [#Rule 15 + 'decl', 3, +sub +#line 104 "YappParse.yp" +{ undef } + ], + [#Rule 16 + 'decl', 4, +sub +#line 106 "YappParse.yp" +{ + for ( @{$_[3]} ) { + my($symbol,$lineno)=@$_; + + exists($$nterm{$symbol}) + and do { + _SyntaxError(0, + "Non-terminal $symbol redefined: ". + "Previously defined line $$syms{$symbol}", + $lineno); + next; + }; + delete($$term{$symbol}); #not a terminal + $$nterm{$symbol}=undef; #is a non-terminal + } + } + ], + [#Rule 17 + 'decl', 3, +sub +#line 122 "YappParse.yp" +{ $expect=$_[2][0]; undef } + ], + [#Rule 18 + 'decl', 2, +sub +#line 123 "YappParse.yp" +{ $_[0]->YYErrok } + ], + [#Rule 19 + 'typedecl', 0, undef + ], + [#Rule 20 + 'typedecl', 3, undef + ], + [#Rule 21 + 'symlist', 2, +sub +#line 130 "YappParse.yp" +{ push(@{$_[1]},$_[2]); $_[1] } + ], + [#Rule 22 + 'symlist', 1, +sub +#line 131 "YappParse.yp" +{ [ $_[1] ] } + ], + [#Rule 23 + 'identlist', 2, +sub +#line 134 "YappParse.yp" +{ push(@{$_[1]},$_[2]); $_[1] } + ], + [#Rule 24 + 'identlist', 1, +sub +#line 135 "YappParse.yp" +{ [ $_[1] ] } + ], + [#Rule 25 + 'body', 2, +sub +#line 140 "YappParse.yp" +{ + $start + or $start=$$rules[1][0]; + + ref($$nterm{$start}) + or _SyntaxError(2,"Start symbol $start not found ". + "in rules section",$_[2][1]); + + $$rules[0]=[ '$start', [ $start, chr(0) ], undef, undef ]; + } + ], + [#Rule 26 + 'body', 1, +sub +#line 150 "YappParse.yp" +{ _SyntaxError(2,"No rules in input grammar",$_[1][1]); } + ], + [#Rule 27 + 'rulesec', 2, undef + ], + [#Rule 28 + 'rulesec', 1, undef + ], + [#Rule 29 + 'rules', 4, +sub +#line 157 "YappParse.yp" +{ _AddRules($_[1],$_[3]); undef } + ], + [#Rule 30 + 'rules', 2, +sub +#line 158 "YappParse.yp" +{ $_[0]->YYErrok } + ], + [#Rule 31 + 'rhss', 3, +sub +#line 161 "YappParse.yp" +{ push(@{$_[1]},$_[3]); $_[1] } + ], + [#Rule 32 + 'rhss', 1, +sub +#line 162 "YappParse.yp" +{ [ $_[1] ] } + ], + [#Rule 33 + 'rule', 3, +sub +#line 165 "YappParse.yp" +{ push(@{$_[1]}, $_[2], $_[3]); $_[1] } + ], + [#Rule 34 + 'rule', 1, +sub +#line 166 "YappParse.yp" +{ + my($code)=undef; + + defined($_[1]) + and $_[1][-1][0] eq 'CODE' + and $code = ${pop(@{$_[1]})}[1]; + + push(@{$_[1]}, undef, $code); + + $_[1] + } + ], + [#Rule 35 + 'rhs', 0, undef + ], + [#Rule 36 + 'rhs', 1, undef + ], + [#Rule 37 + 'rhselts', 2, +sub +#line 183 "YappParse.yp" +{ push(@{$_[1]},$_[2]); $_[1] } + ], + [#Rule 38 + 'rhselts', 1, +sub +#line 184 "YappParse.yp" +{ [ $_[1] ] } + ], + [#Rule 39 + 'rhselt', 1, +sub +#line 187 "YappParse.yp" +{ [ 'SYMB', $_[1] ] } + ], + [#Rule 40 + 'rhselt', 1, +sub +#line 188 "YappParse.yp" +{ [ 'CODE', $_[1] ] } + ], + [#Rule 41 + 'prec', 2, +sub +#line 192 "YappParse.yp" +{ + defined($$term{$_[2][0]}) + or do { + _SyntaxError(1,"No precedence for symbol $_[2][0]", + $_[2][1]); + return undef; + }; + + ++$$precterm{$_[2][0]}; + $$term{$_[2][0]}[1]; + } + ], + [#Rule 42 + 'epscode', 0, +sub +#line 205 "YappParse.yp" +{ undef } + ], + [#Rule 43 + 'epscode', 1, +sub +#line 206 "YappParse.yp" +{ $_[1] } + ], + [#Rule 44 + 'code', 1, +sub +#line 209 "YappParse.yp" +{ $_[1] } + ], + [#Rule 45 + 'tail', 0, undef + ], + [#Rule 46 + 'tail', 1, +sub +#line 215 "YappParse.yp" +{ $tail=$_[1] } + ] +], + @_); + bless($self,$class); +} + +#line 218 "YappParse.yp" + +sub _Error { + my($value)=$_[0]->YYCurval; + + my($what)= $token ? "input: '$$value[0]'" : "end of input"; + + _SyntaxError(1,"Unexpected $what",$$value[1]); +} + +sub _Lexer { + + #At EOF + pos($$input) >= length($$input) + and return('',[ undef, -1 ]); + + #In TAIL section + $lexlevel > 1 + and do { + my($pos)=pos($$input); + + $lineno[0]=$lineno[1]; + $lineno[1]=-1; + pos($$input)=length($$input); + return('TAILCODE',[ substr($$input,$pos), $lineno[0] ]); + }; + + #Skip blanks + $lexlevel == 0 + ? $$input=~m{\G((?: + [\t\ ]+ # Any white space char but \n + | \#[^\n]* # Perl like comments + | /\*.*?\*/ # C like comments + )+)}xsgc + : $$input=~m{\G((?: + \s+ # any white space char + | \#[^\n]* # Perl like comments + | /\*.*?\*/ # C like comments + )+)}xsgc + and do { + my($blanks)=$1; + + #Maybe At EOF + pos($$input) >= length($$input) + and return('',[ undef, -1 ]); + + $lineno[1]+= $blanks=~tr/\n//; + }; + + $lineno[0]=$lineno[1]; + + $$input=~/\G([A-Za-z_][A-Za-z0-9_]*)/gc + and return('IDENT',[ $1, $lineno[0] ]); + + $$input=~/\G('(?:[^'\\]|\\\\|\\'|\\)+?')/gc + and do { + $1 eq "'error'" + and do { + _SyntaxError(0,"Literal 'error' ". + "will be treated as error token",$lineno[0]); + return('IDENT',[ 'error', $lineno[0] ]); + }; + return('LITERAL',[ $1, $lineno[0] ]); + }; + + $$input=~/\G(%%)/gc + and do { + ++$lexlevel; + return($1, [ $1, $lineno[0] ]); + }; + + $$input=~/\G{/gc + and do { + my($level,$from,$code); + + $from=pos($$input); + + $level=1; + while($$input=~/([{}])/gc) { + substr($$input,pos($$input)-1,1) eq '\\' #Quoted + and next; + $level += ($1 eq '{' ? 1 : -1) + or last; + } + $level + and _SyntaxError(2,"Unmatched { opened line $lineno[0]",-1); + $code = substr($$input,$from,pos($$input)-$from-1); + $lineno[1]+= $code=~tr/\n//; + return('CODE',[ $code, $lineno[0] ]); + }; + + if($lexlevel == 0) {# In head section + $$input=~/\G%(left|right|nonassoc)/gc + and return('ASSOC',[ uc($1), $lineno[0] ]); + $$input=~/\G%(start)/gc + and return('START',[ undef, $lineno[0] ]); + $$input=~/\G%(expect)/gc + and return('EXPECT',[ undef, $lineno[0] ]); + $$input=~/\G%{/gc + and do { + my($code); + + $$input=~/\G(.*?)%}/sgc + or _SyntaxError(2,"Unmatched %{ opened line $lineno[0]",-1); + + $code=$1; + $lineno[1]+= $code=~tr/\n//; + return('HEADCODE',[ $code, $lineno[0] ]); + }; + $$input=~/\G%(token)/gc + and return('TOKEN',[ undef, $lineno[0] ]); + $$input=~/\G%(type)/gc + and return('TYPE',[ undef, $lineno[0] ]); + $$input=~/\G%(union)/gc + and return('UNION',[ undef, $lineno[0] ]); + $$input=~/\G([0-9]+)/gc + and return('NUMBER',[ $1, $lineno[0] ]); + + } + else {# In rule section + $$input=~/\G%(prec)/gc + and return('PREC',[ undef, $lineno[0] ]); + } + + #Always return something + $$input=~/\G(.)/sg + or die "Parse::Yapp::Grammar::Parse: Match (.) failed: report as a BUG"; + + $1 eq "\n" + and ++$lineno[1]; + + ( $1 ,[ $1, $lineno[0] ]); + +} + +sub _SyntaxError { + my($level,$message,$lineno)=@_; + + $message= "*". + [ 'Warning', 'Error', 'Fatal' ]->[$level]. + "* $message, at ". + ($lineno < 0 ? "eof" : "line $lineno"). + ".\n"; + + $level > 1 + and die $message; + + warn $message; + + $level > 0 + and ++$nberr; + + $nberr == 20 + and die "*Fatal* Too many errors detected.\n" +} + +sub _AddRules { + my($lhs,$lineno)=@{$_[0]}; + my($rhss)=$_[1]; + + ref($$nterm{$lhs}) + and do { + _SyntaxError(1,"Non-terminal $lhs redefined: ". + "Previously declared line $$syms{$lhs}",$lineno); + return; + }; + + ref($$term{$lhs}) + and do { + my($where) = exists($$token{$lhs}) ? $$token{$lhs} : $$syms{$lhs}; + _SyntaxError(1,"Non-terminal $lhs previously ". + "declared as token line $where",$lineno); + return; + }; + + ref($$nterm{$lhs}) #declared through %type + or do { + $$syms{$lhs}=$lineno; #Say it's declared here + delete($$term{$lhs}); #No more a terminal + }; + $$nterm{$lhs}=[]; #It's a non-terminal now + + my($epsrules)=0; #To issue a warning if more than one epsilon rule + + for my $rhs (@$rhss) { + my($tmprule)=[ $lhs, [ ], splice(@$rhs,-2) ]; #Init rule + + @$rhs + or do { + ++$$nullable{$lhs}; + ++$epsrules; + }; + + for (0..$#$rhs) { + my($what,$value)=@{$$rhs[$_]}; + + $what eq 'CODE' + and do { + my($name)='@'.++$labelno."-$_"; + push(@$rules,[ $name, [], undef, $value ]); + push(@{$$tmprule[1]},$name); + next; + }; + push(@{$$tmprule[1]},$$value[0]); + } + push(@$rules,$tmprule); + push(@{$$nterm{$lhs}},$#$rules); + } + + $epsrules > 1 + and _SyntaxError(0,"More than one empty rule for symbol $lhs",$lineno); +} + +sub Parse { + my($self)=shift; + + @_ > 0 + or croak("No input grammar\n"); + + my($parsed)={}; + + $input=\$_[0]; + + $lexlevel=0; + @lineno=(1,1); + $nberr=0; + $prec=0; + $labelno=0; + + $head=(); + $tail=""; + + $syms={}; + $token={}; + $term={}; + $nterm={}; + $rules=[ undef ]; #reserve slot 0 for start rule + $precterm={}; + + $start=""; + $nullable={}; + $expect=0; + + pos($$input)=0; + + + $self->YYParse(yylex => \&_Lexer, yyerror => \&_Error); + + $nberr + and _SyntaxError(2,"Errors detected: No output",-1); + + @$parsed{ 'HEAD', 'TAIL', 'RULES', 'NTERM', 'TERM', + 'NULL', 'PREC', 'SYMS', 'START', 'EXPECT' } + = ( $head, $tail, $rules, $nterm, $term, + $nullable, $precterm, $syms, $start, $expect); + + undef($input); + undef($lexlevel); + undef(@lineno); + undef($nberr); + undef($prec); + undef($labelno); + + undef($head); + undef($tail); + + undef($syms); + undef($token); + undef($term); + undef($nterm); + undef($rules); + undef($precterm); + + undef($start); + undef($nullable); + undef($expect); + + $parsed +} + + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/AST/Expression.pm b/blib6/pugs/perl5/lib/Pugs/AST/Expression.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/AST/Expression.pm @@ -0,0 +1,36 @@ +package Pugs::AST::Expression; + +use strict; +use warnings; +use Data::Dumper; + +sub term { + { term => $_[1]{'term'}->() ,} +} + +sub operator { + my $self = shift; + my $match = shift; + # die "not a match" unless ref($match) eq 'Pugs::Runtime::Match'; + my %h = %$match; + my %opt = @_; + + #print "capture ", Dumper($match) if $opt{'fixity'} eq 'circumfix'; + for ( keys %h ) { + $h{$_} = $h{$_}->(); + } + my @a = @$match; + if ( @a ) { + $a = shift @a; + for ( @$a ) { + $_ = $self->operator( $_ ); + ${$_}{fixity} = $opt{fixity}; + } + $h{list} = $a; + delete $opt{fixity}; + } + $h{$_} = $opt{$_} for keys %opt; + return \%h; +} + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Compiler/Grammar.pm b/blib6/pugs/perl5/lib/Pugs/Compiler/Grammar.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Compiler/Grammar.pm @@ -0,0 +1,120 @@ +use strict; +use warnings; +#use Smart::Comments; + +package Pugs::Compiler::Grammar; + +our $VERSION = '0.28'; + +use Pugs::Grammar::Rule; +use Pugs::Emitter::Grammar::Perl5; +use Carp qw(carp croak); + +sub compile { + my ($class, $src, $opts) = @_; + $opts ||= {}; + my $match = Pugs::Grammar::Rule->spec($src); + if ($match->bool) { + ## $match + my $capture = $match->(); + my $leading_block = $capture->{block}; + ### leading block: $leading_block + my $ast = $capture->{grammar}; + ## $ast + my $perl5; + for my $g (@$ast) { + ### Grammar found... + $g = $g->(); + my ($name) = keys %$g; + ### Grammar: $name + $perl5 .= Pugs::Emitter::Grammar::Perl5::emit($g, $opts); + } + bless { + source => $src, + ast => $ast, + perl5 => $perl5, + }, $class; + } else { + carp "Failed to compile the grammar source"; + } +} + +sub perl5 { + $_[0]->{perl5}; +} + +1; +__END__ + +=head1 NAME + +Pugs::Compiler::Grammar - Compiler for Perl 6 Grammars + +=head1 SYNOSPIS + + use Pugs::Compiler::Grammar; + my $grammar = q{ + grammar MyC; + + token def { + ? ';' + } + + token type { int | float | double | char } + + token var_list { + **{1} ? [ ',' ? ]* + } + + grammar MyVB; + + token def { + 'Dim' + [ 'As' ]? ? ';' + } + }; + my $obj = Pugs::Compiler::Grammar->compile($grammar); + my $perl5 = $obj->perl5; + eval $perl5; die $@ if $@; + my $match = MyC->def("float foo;"); + print "type: ", $match->{type}, "\n"; + print "vars: ", $match->{var_list}, "\n"; + $match = MyVB->def("Dim foo, bar;"); + print "vars: ", $match->{'MyC.var_list'}, "\n"; + +=head1 METHODS + +=over + +=item C<< $obj = Pugs::Compile::Grammar->compile($src) >> + +Acts as contructor. Accepts a string containing the grammar +specs and returns a Pugs::Compiler::Grammar instance. + +=item C<< $perl5 = $obj->perl5() >> + +Returns a string containing the Perl source for the grammars +compiled. + +=back + +=head1 AUTHOR + +The Pugs contributors Eperl6-compiler@perl.orgE. + +=head1 COPYRIGHT + +Copyright 2007 by Agent Zhang and others. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +See L + +=head1 SEE ALSO + +L, +L, +L, +L. + diff --git a/blib6/pugs/perl5/lib/Pugs/Compiler/Regex.pm b/blib6/pugs/perl5/lib/Pugs/Compiler/Regex.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Compiler/Regex.pm @@ -0,0 +1,506 @@ +package Pugs::Compiler::Regex; + +#use Smart::Comments; + +our $VERSION = '0.28'; +# Documentation in the __END__ +use strict; +use warnings; + +use Pugs::Grammar::Rule; +use Pugs::Compiler::RegexPerl5; + +use Pugs::Emitter::Rule::Perl5; +use Pugs::Emitter::Rule::Perl5::Ratchet; + +use Pugs::Runtime::Regex; + +# complete the dependency circularity +push @Pugs::Grammar::Rule::ISA, 'Pugs::Grammar::Base'; + +use Carp qw( croak carp ); +use Data::Dumper; +use Symbol 'qualify_to_ref'; +use Digest::MD5 'md5_hex'; + +our $NoCache = $ENV{PCR_NO_CACHE}; # Depresses any caching if set to true + +my $cache; +eval { + require Cache::FileCache; + $cache = new Cache::FileCache( { 'namespace' => 'v6-rules' } ); +}; + +sub new { $_[0] } + +sub compile { + local $::_V6_MATCH_; # avoid messing with global $/ + + # $class->compile( $source ) + # $class->compile( $source, { p=>1 } ) + # $class->compile( $source, { signature => $sig } ) -- TODO + + my ( $class, $rule_source, $param ) = @_; + + return Pugs::Compiler::RegexPerl5->compile( $rule_source, $param ) + if exists $param->{P5} || exists $param->{Perl5}; + #warn length($rule_source); + + my $self = { source => $rule_source }; + + #print Dumper @_; + + # XXX - should use user's lexical pad instead of an explicit grammar? + $self->{grammar} = delete $param->{grammar} || + 'Pugs::Grammar::Base'; + $self->{ratchet} = delete $param->{ratchet} || + 0; + + $self->{p} = delete $param->{pos} || + delete $param->{p}; + # default = undef; + delete $param->{p}; + + $self->{sigspace} = delete $param->{sigspace} || + delete $param->{s} || + 0; + delete $param->{s}; + + $self->{continue} = delete $param->{continue} || + delete $param->{c} || + 0; + delete $param->{c}; + + $self->{ignorecase} = delete $param->{ignorecase} || + delete $param->{i} || + 0; + delete $param->{i}; + + my $error; + $error .= "Error in rule: unknown parameter '$_'" + for keys %$param; + croak $error if %$param; + + my $digest = md5_hex(Dumper($self)); + my $cached; + + if (!$NoCache && $cache && ($cached = $cache->get($digest))) { + ### using cached rule... + $self->{perl5} = $cached; + } + else { + ### compiling rule... + + #print 'rule source: ', $self->{source}, "\n"; + #print "match: ", Dumper( Pugs::Grammar::Rule->rule( $self->{source} ) ); + my $ast = Pugs::Grammar::Rule->rule( + $self->{source} )->(); + if (!defined $ast) { + carp "Invalid regex syntax"; + return undef; + } + ### rule AST: $ast + + # save the ast for debugging + $self->{ast} = $ast; + + #warn "ast: ",Dumper($ast),"\n"; + #die "Error in rule: '$rule_source' at: '$ast->tail'\n" if $ast->tail; + #print 'rule ast: ', do{use Data::Dumper; Dumper($ast{capture})}; + + #use Pugs::Emitter::Rule::Perl5::Preprocess; + #my $ast2 = Pugs::Emitter::Rule::Perl5::Preprocess::emit( + # $self->{grammar}, $ast, $self ); + + if ( $self->{ratchet} ) { + $self->{perl5} = Pugs::Emitter::Rule::Perl5::Ratchet::emit( + $self->{grammar}, $ast, $self ); + #print "token: ", $self->{perl5}; + } + else { + $self->{perl5} = Pugs::Emitter::Rule::Perl5::emit( + $self->{grammar}, $ast, $self ); + } + #print 'rule perl5: ', do{use Data::Dumper; Dumper($self->{perl5})}; + + $cache->set($digest, $self->{perl5}, 'never') if $cache; + } + + #our $evals++; + + local $@; + $self->{code} = eval + # "\#line " . ($evals*1000) . "\n" . + $self->{perl5}; + die "Error in evaluation: $@\nSource:\n$self->{perl5}\n" if $@; + + #my $code = $self->{code}; + #my $e = $evals; + #my $c = $self->{perl5}; + #my $x = 1; + #$c =~ s/\n/"\n".++$x.": "/seg; + #$self->{code} = sub { print "calling #$e <<< $rule_source >>> compiles to <<< $c >>>\n"; $code->(@_); }; + + bless $self, $class; +} + +sub code { + my $rule = shift; + sub { + $rule->match( $_[1], $_[0], $_[2], $_[3] ); + } +} + +sub match { + my ( $rule, $str, $grammar, $flags, $state ) = @_; + + #print "match: ",Dumper($rule); + #print "match: ",Dumper(\@_); + #print "PCR::match: ",Dumper($_[2]); + + return Pugs::Runtime::Match->new( { bool => \0 } ) + unless defined $str; # XXX - fix? + + if ( ref $grammar eq 'HASH' ) { + # backwards compatibility - grammar can now be specified in $flags + $state = $flags; + $flags = $grammar; + $grammar = $flags->{grammar}; + } + + $grammar ||= $rule->{grammar}; + #print "match: grammar $rule->{grammar}, $_[0], $flags\n"; + #print "match: Variables: ", Dumper ( $flags->{args} ) if defined $flags->{args}; + #print "match: Flags: ", Dumper ( $flags ) if defined $flags; + + my $p = defined $flags->{p} + ? $flags->{p} + : defined $flags->{pos} + ? $flags->{pos} + : $rule->{p}; + + my $continue = defined $flags->{c} + ? $flags->{c} + : defined $flags->{continue} + ? $flags->{continue} + : $rule->{continue}; + + my $ignorecase = defined $flags->{i} + ? $flags->{i} + : defined $flags->{ignorecase} + ? $flags->{ignorecase} + : $rule->{ignorecase}; + + #print "flag p"; + #print "match: grammar $rule->{grammar}, $str, %$flags\n"; + #print $rule->{code}; + + # XXX BUG! - $rule->{code} disappeared - in t/08-hash.t ??? + unless ( defined $rule->{code} ) { + local $@; + if (!defined $rule->{perl5}) { + croak "Error in evaluation: \$rule->{perl5} is missing"; + } + $rule->{code} = eval + $rule->{perl5}; + croak "Error in evaluation: $@\nSource:\n$rule->{perl5}" if $@; + } + + my %args; + %args = %{$flags->{args}} if defined $flags && defined $flags->{args}; + $args{p} = $p; + $args{continue} = $continue; + $args{ignorecase} = $ignorecase; + + #print "calling code with ",Dumper([ $grammar,$str, $state,\%args ] ); + my $match = $rule->{code}( + $grammar, + $_[1], # pass $str itself instead of a copy so as to make pos work + $state, + \%args, + ); + #print __PACKAGE__ . ": match result: ", $match->perl; + return $match; +} + +sub reinstall { + _install(0, scalar(caller), @_); +} + +sub install { + _install(1, scalar(caller), @_); +} + +sub _install { + my($check, $caller, $class, $name, @etc) = @_; + + # If we have a fully qualified name, use that, otherwise extrapolate. + my $rule = index($name, '::') > -1 ? $name : $caller."::$name"; + my $slot = qualify_to_ref($rule); + + croak "Can't install regex '$name' as '$rule' which already exists" + if $check && *$slot{CODE}; + + eval { + no warnings 'redefine'; + *$slot = $class->compile(@etc)->code; + }; + warn $@ if $@; +} + +sub _str { defined $_[0] ? $_[0] : 'undef' } +sub _quot { + my $s = $_[0]; + $s =~ s/\\/\\\\/sg; + return $s; +} + +sub perl5 { + my $self = shift; + return "bless {\n" . + " grammar " . "=> q(" . _str( $self->{grammar} ) . "),\n" . + " ratchet " . "=> q(" . _str( $self->{ratchet} ) . "),\n" . + " p " . "=> " . _str( $self->{p} ) . ",\n" . + " sigspace " . "=> q(" . _str( $self->{sigspace} ) . "),\n" . + " ignorecase ". "=> q(" . _str( $self->{ignorecase} )."),\n" . + " code " . "=> " . $self->{perl5} . ",\n" . + " perl5 " . "=> q(" . _quot( $self->{perl5} ) . "), }, " . + "q(" . ref($self) . ")"; +} + +sub perl { perl5(@_) } + +1; + +__END__ + +=head1 NAME + +Pugs::Compiler::Regex - Compiler for Perl 6 Regex + +=head1 SYNOPSIS + + use Pugs::Compiler::Regex; + use Pugs::Runtime::Match; + + $regex = Pugs::Compiler::Regex->compile('a*b'); + $match = $regex->match('aaab'); + print $match->(), "\n"; + print $match->from, "\n"; + print $match->to, "\n"; + + package MyGrammar; + $regex = Pugs::Compiler::Regex->compile( + 'a*', { ratchet => 1, continue => 1, sigspace => 1 } + ); + *my_match = $regex->code(); + $match = MyGrammar->my_match('aaaa'); + print "$match\n"; + + package MyGrammar2; + $regex = Pugs::Compiler::Regex->install( + my_match => 'a*', + { ratchet => 1, continue => 1, sigspace => 1 } + ); + $match = MyGrammar->my_match('aaaa'); + print "$match\n"; + +=head1 DESCRIPTION + +This class provides an implementation for Perl 6 regexes. +It serves as a base class for L and +L. + +=head1 METHODS + +=over + +=item C<< $regex = Pugs::Compiler::Regex->compile($str, $params); >> + +This method acts like a constructor, which returns a +L object from the p6 regex +specified in C<$str>, or throws an exception on +invalid rule syntax. + +C<$params> is an optional argument which specifies the +following p6 regex modifiers: + +=over + +=item C<< grammar => 'Pugs::Grammar::Base' >> + +Specify which namespace (Grammar) the rule belongs to. +if C is not specified, then C<"Pugs::Grammar::Base"> will +be assumed. + +=item C<< continue => 0 >> + +=item C<< c => 0 >> + +These modifiers cause the pattern to continue +scanning from the string's current C: + +Note that in Perl 6 form + + m:c/pattern/ + +is roughlh equivalent to + + m:p/ .*? pattern / + +Here is an example: + + package Foo; + Pugs::Compiler::Regex->install( + word => '\w+', + { ratchet => 1, continue => 1 } + ); + $s = 'hello world'; + $match = Foo->word($s); # got 'hello' + $match = Foo->word($s); # got 'world' + +XXX Note that C or C currently are +not supported in non-ratchet mode. + +=item C<< ratchet => 0 >> + +Disable backtracking. Much faster. Defaults to 0. +(L and +L have the default +value of 1). + +=item C<< pos => undef >> + +=item C<< p => undef >> + +Specify a string position to match. Starts from zero. +Defaults to C, which matches anywhere in the string. + +=item C<< sigspace => 0 >> + +Whitespace is significant. Defaults to 0 for +L while 1 for +L. + +=item C<< ignorecase => 0 >> + +Ignore character case. Defaults to 0 for +L. + +=back + +=item C<< $regex->perl5() >> + +=item C<< $regex->perl() >> + +Return a string holding the Perl 5 code for reconstructing +the current L object. + +We are trying to make the C method does something +like serializing a L instance. + +If you want the raw Perl 5 code generated by the +various emitters, use C<< $regex->{perl5} >> directly. + +=item C<< $regex->match($str, $grammar, $params) >> + +Performs matching action on C<$str>. Note that it's +a thin wrapper around the p5 code compiled from the p6 +regex with run-time modifier handling via the C<$params> +argument. + +Here is an example: + + $regex = Pugs::Compiler::regex->compile('a*\w'); + my $match = $regex->match('aaa'); + print "Capture: $match"; + print "From: ", $match->from; + print "To: ", $match->to; + +=item C<< $regex->code() >> + +Returns a closure (or an anonymous sub) which does the actual +matching task. For example: + + $regex = Pugs::Compiler::Regex->compile('a|b', { ratchet => 1 }); + my $sub = $regex->code(); + my $match = $sub->('MyGrammar', 'aaa'); + +Or inserts the sub into the current package: + + package Foo; + $regex = Pugs::Compiler::Regex->compile('a*'); + *match = $regex->code(); + my $match = __PACKAGE__->match('aaa'); + +Technically it's a thin wrapper around the C method. + +=item C<< $regex->install($name, @args_for_compile) >> + +Installs the subroutine returned from the C method as +a named subroutine using the name specified by C<$name>; + +If C<$name> is fully qualified, then the corresponding +package is used, otherwise the current package is assumed. + +C<@args_for_compile> are those arguments fed into the C +method. + +It will croak if there's already a sub with the same name +exists. If that's not what you want, use the C +method instead. + +Here are some examples: + + package Bar; + Pugs::Compiler::Regex->install(match => 'a*', {ratchet => 1}); + $match = Bar->match('aaa'); + + # The following line dies with the message + # "Can't install regex 'match' as 'Bar::match' which already + # exists": + Pugs::Compiler::Regex->install(match => 'b*'); + +=item C<< $regex->reinstall($name, @args_for_compile) >> + +Like the C method but it can replaces the named sub +if it already exists: + + package Bar; + Pugs::Compiler::Regex->install('match', 'a*', {ratchet => 1}); + Pugs::Compiler::Regex->reinstall('match', 'b*'); + }; + $match = Bar->match('bbb'); # matched here + +=back + +=head1 PACKAGE VARIABLES + +=over + +=item C<< $Pugs::Compiler::Regex::NoCache >> + +By default, the C method will cache the compiled +form (p5 source) of the p6 regex. The C variable +prevents any caching. + +=back + +=head1 AUTHORS + +The Pugs Team Eperl6-compiler@perl.orgE. + +=head1 SEE ALSO + +The Perl 6 Rules Spec: L + +=head1 COPYRIGHT + +Copyright 2006 by Flavio Soibelmann Glock and others. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/blib6/pugs/perl5/lib/Pugs/Compiler/RegexPerl5.pm b/blib6/pugs/perl5/lib/Pugs/Compiler/RegexPerl5.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Compiler/RegexPerl5.pm @@ -0,0 +1,123 @@ +package Pugs::Compiler::RegexPerl5; + +# Version in Pugs::Compiler::Rule +# Documentation in the __END__ +use 5.006; +use strict; +use warnings; + +#use base 'Pugs::Compiler::Regex'; + +#use Pugs::Compiler::Regex; +#sub code { (+shift)->Pugs::Compiler::Regex::code( @_ ) } + +# http://www.foo.be/docs/tpj/issues/vol2_3/tpj0203-0002.html +# is a good reference on the use of pos() + +sub compile { + my ( $class, $rule_source, $param ) = @_; + my $self = { source => $rule_source }; + $param = ref $param ? { %$param } : {}; + delete $param->{P5}; + delete $param->{Perl5}; + $self->{continue} = delete $param->{continue} || + delete $param->{c} || + 0; + warn "Error in rule: unknown parameter '$_'" + for keys %$param; + + # TODO - set "prior" + + my $captures = q' + for ( 1 .. $#+ ) { + push @match, Pugs::Runtime::Match->new({ + str => $_[1], from => \\(0+$-[$_]), to => \\(0+$+[$_]), + bool => \\1, match => [], named => {}, capture => undef, + }); + } + ' . + #print "POS $bool ",(0+$-[0]),"-",(0+$+[0]),"\n";select(undef, undef, undef, 0.1); + 'return Pugs::Runtime::Match->new({ + str => $_[1], from => \\(0+$-[0]), to => \\(0+$+[0]), + bool => \\$bool, match => \\@match, named => {}, capture => undef, + }); + '; + $self->{perl5} = +q(do { + my $rule; + $rule = sub { # grammar, string, state, args + no warnings 'uninitialized'; + my $bool; + my @match; + + return $rule->($_[0], \\$_[1], $_[2], $_[3]) + unless ref( $_[1] ); # backwards compatibility + + #print "POS ${$_[1]} ",pos(${$_[1]}),"\n"; + #print "p5 $_[3]{p} \n"; + + if( $_[3]{continue} ) { + pos(${$_[1]}) = $_[3]{p} + if defined $_[3]{p}; + $bool = \( ${$_[1]} =~ /) . $rule_source . q(/g \) ? 1 : 0; ) . + $captures . q( + } + + if ( defined $_[3]{p} ) { + pos(${$_[1]}) = $_[3]{p}; + $bool = \( ${$_[1]} =~ /\G\(?:) . $rule_source . q(\)/ \) ? 1 : 0; ) . + $captures . q( + } + else { + $bool = \( ${$_[1]} =~ /) . $rule_source . q(/ \) ? 1 : 0; ) . + $captures . q( + } +}; +} +); + # print 'rule perl5: ', do{use Data::Dumper; Dumper($self->{perl5})}; + + local $@; + $self->{code} = eval + $self->{perl5}; + die "Error in evaluation: $@\nSource:\n$self->{perl5}\n" if $@; + + bless $self, 'Pugs::Compiler::Regex'; +} + +1; + +__END__ + +=head1 NAME + +Pugs::Compiler::RegexPerl5 - Compiler for Perl 6 style "Perl5" regex + +=head1 DESCRIPTION + +This module provides an implementation for Perl 6 regexes that use the "Perl5" switch: + + :Perl5 /.*/ + + :P5 /.*/ + +See L for documentation. + +=head1 AUTHORS + +The Pugs Team Eperl6-compiler@perl.orgE. + +=head1 SEE ALSO + +The Perl 6 Rules Spec: L + +=head1 COPYRIGHT + +Copyright 2006 by Flavio Soibelmann Glock and others. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/blib6/pugs/perl5/lib/Pugs/Compiler/Rule.pm b/blib6/pugs/perl5/lib/Pugs/Compiler/Rule.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Compiler/Rule.pm @@ -0,0 +1,219 @@ +use 5.006001; +use strict; +use warnings; + +package Pugs::Compiler::Rule; + +our $VERSION = '0.28'; + +use base 'Pugs::Compiler::Regex'; + +sub compile { + my ( $class, $rule_source, $param ) = @_; + $param = ref $param ? { %$param } : {}; + $param->{ratchet} = 1 + unless exists $param->{ratchet}; + $param->{sigspace} = 1 + unless exists $param->{sigspace} || + exists $param->{s}; + $class->SUPER::compile( $rule_source, $param ); +} + +1; +__END__ + +=head1 NAME + +Pugs::Compiler::Rule - Compiler for Perl 6 regexes + +=head1 VERSION + +This document describes Pugs::Compiler::Rule 0.28 released +on 31 Oct, 2007. + +=head1 SYNOPSIS + +Un-named rules are objects: + + use Pugs::Compiler::Rule; + + my $rule = Pugs::Compiler::Rule->compile( '((.).).' ); + my $match = $rule->match( 'abc' ); + + if ($match) { # true + print $match; # "abc" + print $match->from; # 0 + print $match->to; # 3 + print $match->[0]; # "ab" + print $match->[0][0]; # "a" + } + +Named rules are methods in a Grammar: + + package MyGrammar; + use Pugs::Compiler::Rule; + use base 'Pugs::Grammar::Base'; + + Pugs::Compiler::Rule->install( rule => '((.).).' ); + my $match = MyGrammar->rule( 'abc' ); + +Rules may have parameters: + + $grammar->install(subrule => $source, { signature => $sig } ); + + $grammar->install(rule => q{ + + }); + +where C<$grammar> is normally a Perl 5 package. + +=head1 DESCRIPTION + +This module provides an pure Perl 5 implementation for Perl 6 regexes, +which does not depend on the Haskell Pugs. + +It is a front-end to several other modules: + +Front-end Modules + +=over 4 + +=item * L compiles Perl 6 grammars to Perl 5. + +=item * L compiles Perl 6 rules to Perl 5. + +=item * L compiles Perl 6 tokens to Perl 5. + +=item * L compiles Perl 6 regexes to Perl 5. + +=item * L wraps Perl 5 regexes to return a B object. + +=back + +Runtime Classes + +=over 4 + +=item * L provides the runtime engine for Rules. + +=item * L represents a B object. + +=item * L represents a B class / object. + +=back + +Grammars + +=over 4 + +=item * L parses the Rules syntax. + +=item * L is the base Grammar: , . + +=back + +Code Emitters + +=over 4 + +=item * L converts parsed Rules to Perl 5 code. + +=item * L converts parsed :ratchet Rules to Perl 5 code. + +=item * L converts parsed grammars to Perl 5 code. + +=back + +=head1 INHERITANCE + + Pugs::Compiler::Rule + isa Pugs::Compiler::Regex + +=head1 METHODS + +This class (i.e. L) is a +subclass of L and thus owns +all the methods of its base class. See +L for the detailed docs. + +=over + +=item C<< $rule = Pugs::Compiler::Rule->compile($p6_regex, $params) >> + +Specifically, this class overrides the C +method of L which resets +the following options' default values: + +=over + +=item C<< ratchet => 1 >> + +Here is an example: + + $rule = Pugs::Compiler::Rule->compile( + 'a*\w', + ); + my $match = $rule->match('aaa'); + # $match->bool is false since no backtracking + # happened + +=item C<< sigspace => 1 >> + +Here is an example: + + my $rule = Pugs::Compiler::Rule->compile( + 'a b', + ); + my $match = $rule->match('a b'); + ok $match->bool, 'sigspace works'; + is $match->(), 'a b', 'sigspace works (2)'; + +=back + +=back + +=head1 CAVEATS + +This is an experimental development version. The API is still in flux. + +The set of implemented features depend on the C switch. + +=head1 AUTHORS + +The Pugs Team C<< >>. + +Please join us on irc.freenode.net C<#perl6> if you'd like to participate. + +=head1 SEE ALSO + +=over + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +The Perl 6 Rules Spec: L + +=back + +=head1 COPYRIGHT + +Copyright 2006, 2007 by Flavio Soibelmann Glock and others. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut + diff --git a/blib6/pugs/perl5/lib/Pugs/Compiler/Token.pm b/blib6/pugs/perl5/lib/Pugs/Compiler/Token.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Compiler/Token.pm @@ -0,0 +1,48 @@ +package Pugs::Compiler::Token; + +our $VERSION = '0.28'; + +use strict; +use warnings; + +use base 'Pugs::Compiler::Regex'; + +sub compile { + my ( $class, $rule_source, $param ) = @_; + $param = ref $param ? { %$param } : {}; + $param->{ratchet} = 1 + unless defined $param->{ratchet}; + $class->SUPER::compile( $rule_source, $param ); +} + +1; + +__END__ + +=head1 NAME + +Pugs::Compiler::Token - Compiler for Perl 6 Token + +=head1 DESCRIPTION + +This module provides an implementation for Perl 6 Token. +See L for documentation. + +=head1 AUTHORS + +The Pugs Team Eperl6-compiler@perl.orgE. + +=head1 SEE ALSO + +The Perl 6 Rules Spec: L + +=head1 COPYRIGHT + +Copyright 2006 by Flavio Soibelmann Glock and others. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut diff --git a/blib6/pugs/perl5/lib/Pugs/Emitter/Grammar/Perl5.pm b/blib6/pugs/perl5/lib/Pugs/Emitter/Grammar/Perl5.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Emitter/Grammar/Perl5.pm @@ -0,0 +1,169 @@ +package Pugs::Emitter::Grammar::Perl5; + +our $VERSION = '0.28'; + +#use Smart::Comments; +use strict; +use warnings; +use Pugs::Emitter::Rule::Perl5::Ratchet; + +# for safe mode +sub _prune_actions { + my ($ast) = @_; + while (my ($key, $node) = each %$ast) { + next if $key =~ /^_/ or !ref $node; + #warn $key; + if ($key eq 'closure') { + #die "Found closures!"; + next if ref $node ne 'HASH'; + my $code = $node->{closure}; + if ($code and !ref $code and $code =~ /\w+/) { + die "ERROR: code blocks not allowed in safe mode: \"$code\"\n"; + } + } + if (ref $node) { + my $ref = ref $node; + if ($ref eq 'HASH') { + _prune_actions($node); + } elsif ($ref eq 'ARRAY') { + for my $child (@$node) { + if (ref $child and ref $child eq 'HASH') { + _prune_actions($child); + } + } + } + } + } +} + +sub emit { + my $ast = shift; + my $opts = shift; + $opts ||= {}; + ## $ast + my ($name, $stmts) = each %$ast; + my $p5_methods = ''; + ### $name + for my $stmt (@$stmts) { + my $regex = $stmt->(); + my $type = $regex->{type}; + ## $regex + if ($type eq 'block') { + my $code = $regex->{value}; + if ($opts->{safe_mode} && $code =~ /\w+/) { + die "ERROR: verbatim Perl 5 blocks not allowed in safe mode: \"$code\"\n"; + } + $p5_methods .= <<"_EOC_"; +# Code block from grammar spec +$code + +_EOC_ + next; + } + ### struct: $regex->{name} + ## regex AST: $regex->{ast} + my $params = {}; + if ($type eq 'rule') { + $params->{sigspace} = 1; + } + my $body; + + my $ast = $regex->{ast}; + if ($opts->{safe_mode}) { + _prune_actions($ast); + } + + if ($type eq 'regex') { + $body = Pugs::Emitter::Rule::Perl5::emit( + 'Pugs::Grammar::Rule', + $ast, + ) + } else { + $body = Pugs::Emitter::Rule::Perl5::Ratchet::emit( + 'Pugs::Grammar::Rule', + $ast, + $params, + ); + } + $body =~ s/^/ /gm; + $p5_methods .= <<_EOC_; +# $regex->{type} $regex->{name} +*$regex->{name} = +$body; + +_EOC_ + } + # bootstrap the regex parser itself: + my $prefix = $name eq 'Pugs::Grammar::Rule' ? + "#" : ''; + return <<"_EOC_"; +package $name; + +${prefix}use base 'Pugs::Grammar::Base'; + +use Pugs::Runtime::Match; +use Pugs::Runtime::Regex; +use Pugs::Runtime::Tracer (); + +$p5_methods + +1; +_EOC_ +} + +1; +__END__ + +=head1 NAME + +Pugs::Emitter::Grammar::Perl5 - Perl 5 emitter for grammar ASTs + +=head1 SYNOPSIS + + use Pugs::Compiler::Grammar; + use Pugs::Emitter::Grammar::Perl5; + + my $ast = Pugs::Grammar::Rule->grammar(q{ + + grammar MyLang; + + token def { + ? ';' + } + + token type { int | float | double | char } + + token var_list { ? [ ',' ? ]* } + + })->(); + my $perl5 = Pugs::Emitter::Grammar::Perl5::emit($ast); + print $perl5; + +=head1 FUNCTIONS + +=over + +=item C<< $perl5 = Pugs::Emitter::Grammar::Perl5::emit($ast) >> + +Generate Perl 5 source code from the grammar AST returned +by L's grammar parser. + +=back + +=head1 AUTHOR + +The Pugs contributors Eperl6-compiler@perl.orgE. + +=head1 COPYRIGHT + +Copyright (c) 2007 by Agent Zhang (Eagentzh@agentzh.orgE) and others. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +See L + +=head1 SEE ALSO + +L, L. + diff --git a/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Parsec.pm b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Parsec.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Parsec.pm @@ -0,0 +1,405 @@ +package Pugs::Emitter::Rule::Parsec; + +# p6-rule parsec emitter + +use strict; +use warnings; +use Pugs::Grammar::MiniPerl6; +use Data::Dumper; +$Data::Dumper::Indent = 1; + +our $sigspace = 0; +our $capture_counter = 0; +sub get_capture_var { return 'capture_' . $capture_counter++; } + +sub rule_rename($){ + my $orig_name = shift; + return 'rule' . (uc substr $orig_name, 0, 1) . substr $orig_name, 1; +} + +sub to_genparser_string($) { + my $char_parser = shift; + return "($char_parser >>= \\c -> return [c])"; +} + +sub call_constant { + my $str = shift; + $str =~ s/\\/\\\\/g; + $str =~ s/"/\\"/g; + return 'string "' . $str . '"'; +} + +sub emit { + my ($grammar, $ast, $param) = @_; + local $sigspace = $param->{sigspace}; # XXX - $sigspace should be lexical + local $capture_counter = 0; + emit_rule( $ast, '' ) . "\n"; +} + +sub emit_rule { + my $n = $_[0]; + my $tab = $_[1]; + die "unknown node: ", Dumper( $n ) + unless ref( $n ) eq 'HASH'; + #print "NODE ", Dumper($n); + my ( $k, $v ) = each %$n; + # XXX - use real references + no strict 'refs'; + my $code = &$k( $v, $tab ); + return $code; +} + +#rule nodes + +sub non_capturing_group { + return emit_rule( $_[0], $_[1] ); +} + +sub quant { + my $term = $_[0]->{'term'}; + my $quantifier = $_[0]->{quant}; + my $spacing = + ( $sigspace && + ($_[0]->{ws1} ne '' && $_[0]->{ws2} ne '') + ); + my $tab = $spacing ? $_[1] . ' ' : $_[1]; + my $rul = emit_rule( $term, $tab ); + + my $ws = metasyntax('?ws', $tab); + $rul = "$ws\n$tab$rul" if $sigspace && $_[0]->{ws1} ne ''; + $rul = "$rul\n$tab$ws" if $sigspace && $_[0]->{ws2} ne ''; + $rul = "do\n$tab$rul" if $spacing; + return $rul + if $quantifier eq ''; + + # * + ? + my $qual = ''; + return "option \"\" \$ $rul" if $quantifier eq '?'; + + $qual = 'many' if $quantifier eq '*'; + $qual = 'many1' if $quantifier eq '+'; + + die "quantifier not implemented: $quantifier" if $qual eq ''; + + my $final_rul = + "(($qual \$ $rul) >>= \\arr -> return \$ foldr (++) \"\" arr)"; + + return "$final_rul >>\n$tab$ws" if $sigspace and $_[0]->{ws3} ne ''; + return $final_rul; +} + +sub alt { + my @s; + my @alt = @{$_[0]}; + + # clean up alternative body + # XXX maybe can be done earlier (e.g. in parser) + foreach(@alt){ + if(ref eq 'HASH'){ + my($k) = keys %$_; + + if($k eq 'alt'){ + my @sub_alt = @{$_->{alt}}; + $_ = $sub_alt[0]; + push @alt, @sub_alt[1 .. $#sub_alt]; + } + } + } + + my $indent = $_[1] . ' '; + foreach(@alt){ + my $tmp = emit_rule( $_, $indent ); + push @s, $tmp if $tmp; + } + return "do\n$indent" . join "\n$indent<|>\n$indent", @s; +} + +sub concat { + my @inner = @{$_[0]}; + + # clean up concatenation body + # XXX maybe can be done earlier (e.g. in parser) + foreach(@inner){ + if(ref eq 'HASH'){ + my($k) = keys %$_; + + if($k eq 'concat'){ + my @sub_inner = @{$_->{concat}}; + $_ = $sub_inner[0]; + push @inner, @sub_inner[1 .. $#sub_inner]; + } + } + } + + my $indent = $_[1] . ' '; + my $result = 'do'; + foreach(@inner){ + my $tmp = emit_rule( $_, $indent ); + $result .= "\n$indent" . $tmp if $tmp; + } + return $result; +} + +sub dot { + return to_genparser_string("anyChar"); +} + +sub variable {} + +use vars qw( %special_chars ); +BEGIN { + %special_chars = ( +r => "char '\\r'", +n => "char '\\n'", +t => "char '\\t'", +e => "char '\\033'", +f => "char '\\f'", +w => "(alphaNum <|> char '_')", +d => 'digit', +s => 'space', +W => "satisfy (\\x -> x /= '_' && not \$ isAlphaNum x)", +D => 'noneOf "0123456789"', +S => 'noneOf " \\v\\f\\t\\r\\n"', +); + + while(my ($k, $v) = each %special_chars){ + next if + $k eq uc $k or + exists $special_chars{uc $k} or + $v !~ /^char/; + my $chars = substr $v, 6; + chop $chars; + $special_chars{uc $k} = "noneOf \"$chars\""; + } +} +sub special_char { + my $char = substr($_[0],1); + return to_genparser_string($special_chars{$char}) + if exists $special_chars{$char}; + $char = '\\\\' if $char eq '\\'; + return "string \"$char\""; +} + +sub match_variable {} + +sub closure { + my $miniperl6 = substr $_[0], 1, length($_[0]) - 2; + my $haskell = Pugs::Grammar::MiniPerl6->ProductionRule($miniperl6); + $haskell =~ s/\n/\n$_[1]/sg; + # print ">>> MiniPerl6\n$miniperl6\n===\n$haskell\n<<< Haskell\n"; + return "$haskell"; +} + +sub capturing_group { + my $program = $_[0]; + + $program = emit_rule( $program, $_[1] . ' ' ) + if ref( $program ); + + return &get_capture_var . ' <- ' . $program; +} + +sub named_capture { + my $name = $_[0]{ident}; + my $program = $_[0]{rule}; + + return "$name <- " . metasyntax($program->{metasyntax}, $_[1] . ' ', 1) + if exists $program->{metasyntax}; + + return "$name <- " . emit_rule($program, $_[1] . ' '); +} + +sub negate { + my $body = $_[0]; + return not_after($body->{after}, $_[1]) if exists $body->{after}; + return not_before($body->{before}, $_[1]) if exists $body->{before}; + return ''; +} + +sub before { + my $program = $_[0]{rule}; + return 'lookAhead (' . emit_rule($program, $_[1] . ' ') . ')'; +} + +sub not_before { + my $program = $_[0]{rule}; + return 'notFollowedBy $ (' . + emit_rule($program, $_[1] . ' ') . + ") >> return ' '"; + # notFollowedBy :: Show tok => GenParser tok st tok -> GenParser tok st () + # tok = Char in the context so that we have to cast it +} + +sub after {} +sub not_after {} +sub colon {} + +sub constant { + return "string \"$_[0]\""; +} + +use vars qw( %char_class ); +BEGIN { + %char_class = ( +alpha => 'letter', +alnum => 'alphaNum', +ascii => 'satisfy isAscii', +blank => 'oneOf " \\t"', +cntrl => 'satisfy isCotrol', +digit => 'digit', +graph => "satisfy (\\x -> isPrint x && x /= ' ')", +lower => 'lower', +print => 'satisfy isPrint', +punct => "satisfy (\\x -> isPrint x && x /= ' ' && not (isAlphaNum x))", +space => 'space', +upper => 'upper', +word => "(alphaNum <|> char '_')", +xdigit => 'hexDigit', +); +} + +sub metasyntax { + # + my $cmd = $_[0]; + my $prefix = substr( $cmd, 0, 1 ); + + my $named_capturing = !$_[2]; + my $negative_lookahead = 0; + + if ( $prefix eq '@' ) { + # XXX - wrap @array items - see end of Pugs::Grammar::Rule + # TODO - param list + return + "$_[1] do {\n" . + "$_[1] my \$match;\n" . + "$_[1] for my \$subrule ( $cmd ) {\n" . + "$_[1] \$match = " . + call_subrule( '$subrule', '', () ) . ";\n" . + "$_[1] last if \$match;\n" . + "$_[1] }\n" . + "$_[1] my \$bool = (!\$match != 1);\n" . + "$_[1] \$pos = \$match->to if \$bool;\n" . + "$_[1] \$bool;\n" . + "$_[1] }"; + } + if ( $prefix eq '$' ) { + if ( $cmd =~ /::/ ) { + # call method in fully qualified $package::var + # ...->match( $rule, $str, $grammar, $flags, $state ) + # TODO - send $pos to subrule + return + "$_[1] do {\n" . + "$_[1] push \@match,\n" . + "$_[1] $cmd->match( \$s, \$grammar, {p => \$pos}, undef );\n" . + "$_[1] \$pos = \$match[-1]->to;\n" . + "$_[1] !\$match[-1] != 1;\n" . + "$_[1] }" + } + # call method in lexical $var + # TODO - send $pos to subrule + return + "$_[1] do {\n" . + "$_[1] my \$r = Pugs::Runtime::Rule::get_variable( '$cmd' );\n" . + "$_[1] push \@match,\n" . + "$_[1] \$r->match( \$s, \$grammar, {p => \$pos}, undef );\n" . + "$_[1] \$pos = \$match[-1]->to;\n" . + "$_[1] !\$match[-1] != 1;\n" . + "$_[1] }" + } + if ( $prefix eq q(') ) { # single quoted literal ' + $cmd = substr( $cmd, 1, -1 ); + return call_constant( $cmd ); + } + if ( $prefix eq q(") ) { # interpolated literal " + $cmd = substr( $cmd, 1, -1 ); + warn "<\"...\"> not implemented"; + return; + } + if ( $prefix =~ /[-+[]/ ) { # character class + if ( $prefix eq '-' ) { + my $str = substr $cmd, 2, length($cmd) - 3; + $str =~ s/\\>/>/g; # XXX + $str =~ s/\\/\\\\/g; + $str =~ s/"/\\"/g; + + return to_genparser_string("noneOf \"$str\""); + } + elsif ( $prefix eq '+' ) { + $cmd = substr($cmd, 2); + } + + my $str = substr $cmd, 1, length($cmd) - 2; + $str =~ s/\\>/>/g; # XXX + $str =~ s/\\/\\\\/g; + $str =~ s/"/\\"/g; + + return to_genparser_string("oneOf \"$str\""); + } + if ( $prefix eq '?' ) { # non_capturing_subrule / code assertion + $cmd = substr( $cmd, 1 ); + if ( $cmd =~ /^{/ ) { + warn "code assertion not implemented"; + return; + } + $prefix = substr( $cmd, 0, 1 ); + $named_capturing = 0; + } + if ( $prefix eq '!' ) { # negated_subrule / code assertion + $cmd = substr( $cmd, 1 ); + if ( $cmd =~ /^{/ ) { + warn "code assertion not implemented"; + return; + } + $prefix = substr( $cmd, 0, 1 ); + $negative_lookahead = 1; + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq '.' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $prefix =~ /[_[:alnum:]]/ ) { + # "before" and "after" are handled in a separate rule + if ( $cmd eq 'ws' ){ + return 'perl6WhiteSpace'; + # assuming function: + # perl6WhiteSpace = do cls <- getPrevCharClass + # let mod = if cls == WordClass then many1 else many + # do mod whiteSpace + # <|> + # (satisfy (\c -> charClassOf c /= WordClass) >> return "") + + } + if ( $cmd eq 'cut' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq 'commit' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq 'prior' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq 'null' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $char_class{$cmd} ) { + # XXX - inlined char classes are not inheritable, but this should be ok + return to_genparser_string($char_class{$cmd}); + } + # capturing subrule + # + my ( $subrule, $param_list ) = split( /[\(\)]/, $cmd ); + $param_list = '' unless defined $param_list; + my @param = split( ',', $param_list ); + return ($named_capturing ? "$subrule <- " : '') . + rule_rename($subrule) . join '', map { " ($_)" } @param; + } + die "<$cmd> not implemented"; +} + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5.pm b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5.pm @@ -0,0 +1,610 @@ +package Pugs::Emitter::Rule::Perl5; + +use Pugs::Emitter::Rule::Perl5::Ratchet; + +# p6-rule perl5 emitter + +use strict; +use warnings; +use Data::Dumper; +$Data::Dumper::Indent = 1; + +our $capture_count; +our $capture_to_array; +our %capture_seen; + +sub call_subrule { + my ( $subrule, $tab, $positionals, @param ) = @_; + $subrule = "\$_[4]->" . $subrule unless $subrule =~ / :: | \. | -> /x; + $subrule =~ s/\./->/; # XXX - source filter + + $positionals = shift @param if $positionals eq '' && @param == 1; # odd number of elements in hash + #print "PARAM: ",Dumper(@param); + + return +"$tab sub{ +$tab my \$prior = \$::_V6_PRIOR_; +$tab my \$param = { \%{ \$_[7] || {} }, positionals => [ $positionals ], args => {" . + join(", ",@param) . "} }; +$tab \$_[3] = $subrule( \$_[0], \$param, \$_[3], ); +$tab \$::_V6_PRIOR_ = \$prior; +$tab } +"; +} + +sub call_subrule_no_capture { + my ( $subrule, $tab, $positionals, @param ) = @_; + $subrule = "\$_[4]->" . $subrule unless $subrule =~ / :: | \. | -> /x; + $subrule =~ s/\./->/; # XXX - source filter + + $positionals = shift @param if $positionals eq '' && @param == 1; # odd number of elements in hash + #print "PARAM: ",Dumper(@param); + + return +"$tab sub{ +$tab my \$prior = \$::_V6_PRIOR_; +$tab my \$param = { \%{ \$_[7] || {} }, positionals => [ $positionals ], args => {" . + join(", ",@param) . "} }; +$tab \$_[3] = $subrule( \$_[0], \$param, \$_[3], ); +$tab \$_[3]->data->{match} = []; +$tab \$_[3]->data->{named} = {}; +$tab \$::_V6_PRIOR_ = \$prior; +$tab } +"; +} + +sub emit { + my ($grammar, $ast) = @_; + # runtime parameters: $grammar, $string, $state, $arg_list + # rule parameters: see Runtime::Rule.pm + local $capture_count = -1; + local $capture_to_array = 0; + local %capture_seen = (); + #print "emit capture_to_array $capture_to_array\n"; + # print "emit: ", Dumper($ast); + #die emit_rule( $ast, ' ' ); + + return +"do { + package Pugs::Runtime::Regex; + my \$matcher = \n" . emit_rule( $ast, ' ' ) . "; + my \$rule; + \$rule = sub {" . + # grammar, string, state, args + #" print \"match args: \",Dumper(\@_);\n" . + " + my \$tree; + if ( defined \$_[3]{p} + && ! \$_[3]{continue} + ) { + \$matcher->( \$_[1], \$_[2], \$tree, \$tree, \$_[0], \$_[3]{p}, \$_[1], \$_[3] ); + } + else { + \$_[3]{p} ||= 0; + for my \$pos ( \$_[3]{p} .. length( \$_[1] ) ) { + my \$param = { \%{\$_[3]}, p => \$pos }; + \$matcher->( \$_[1], \$_[2], \$tree, \$tree, \$_[0], \$pos, \$_[1], \$param ); + last if \$tree; + } + \$tree = Pugs::Grammar::Base->no_match(\@_) + unless defined \$tree; + } + my \$cap = \$tree->data->{capture}; + if ( ref \$cap eq 'CODE' ) { + \$::_V6_MATCH_ = \$tree; + \$tree->data->{capture} = \\(\$cap->( \$tree )); + }; + if ( \$tree ) { + # \$::_V6_PRIOR_ = \$rule + + my \$prior = \$::_V6_PRIOR_; + \$::_V6_PRIOR_ = sub { + local \$main::_V6_PRIOR_ = \$prior; + \$rule->(\@_); + }; + + } + return \$tree; + } +} +"; +} + +sub emit_rule { + my $n = $_[0]; + my $tab = $_[1] . ' '; + die "unknown node: ", Dumper( $n ) + unless ref( $n ) eq 'HASH'; + #print "NODE ", Dumper($n); + my @keys = grep { substr($_, 0, 1) ne '_' } keys %$n; + my ($k) = @keys; + my $v = $$n{$k}; + # XXX - use real references + no strict 'refs'; + my $code = &$k( $v, $tab ); + return $code; +} + +#rule nodes + +sub capturing_group { + my $program = $_[0]; + + $capture_count++; + { + $capture_seen{$capture_count}++; + local $capture_count = -1; + local $capture_to_array = 0; + local %capture_seen = (); + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + } + + return + "$_[1] positional( $capture_count, " . + ( $capture_to_array || ( $capture_seen{$capture_count} > 1 ? 1 : 0 ) ) . + ", \n" . + $program . + "$_[1] )\n"; +} +sub capture_as_result { + my $program = $_[0]; + + $capture_count++; + { + $capture_seen{$capture_count}++; + local $capture_count = -1; + local $capture_to_array = 0; + local %capture_seen = (); + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + } + + return + "$_[1] capture_as_result( \n" . + $program . + "$_[1] )\n"; +} +sub non_capturing_group { + return emit_rule( $_[0], $_[1] ); +} +sub quant { + my $term = $_[0]->{'term'}; + my $quantifier = $_[0]->{quant} || ''; + my $greedy = $_[0]->{greedy} || ''; # + ? + + if ( ref( $quantifier ) eq 'HASH' ) + { + die "quantifier not implemented: " . Dumper( $quantifier ); + + #return + # "$_[1] concat(\n" . + # join( ',', ($rul) x $count ) . + # "$_[1] )\n"; + } + + my $quant = $quantifier . $greedy; + my $sub = { + '*' =>'greedy_star', + '+' =>'greedy_plus', + '*?'=>'non_greedy_star', + '+?'=>'non_greedy_plus', + '?' =>'optional', + '??'=>'null_or_optional', + '' => '', + }->{$quant}; + die "quantifier not implemented: $quant" + unless defined $sub; + + my $rul; + { + my $cap = $capture_to_array; + local $capture_to_array = $cap || ( $quant ne '' ? 1 : 0 ); + $rul = emit_rule( $term, $_[1] . ' ' ); + } + + return $rul + if $sub eq ''; + return + "$_[1] $sub(\n" . + $rul . + "$_[1] )\n"; +} +sub alt { + my @s; + # print "Alt: ", Dumper($_[0]); + my $count = $capture_count; + my $max = -1; + for ( @{$_[0]} ) { + $capture_count = $count; + + my $_capture_count = $capture_count; + my $_capture_to_array = $capture_to_array; + my %_capture_seen = ( %capture_seen ); + local $capture_count = $_capture_count; + local $capture_to_array = $_capture_to_array; + local %capture_seen = ( %_capture_seen ); + + my $tmp = emit_rule( $_, $_[1].' ' ); + # print ' ',$capture_count; + $max = $capture_count + if $capture_count > $max; + push @s, $tmp if $tmp; + } + $capture_count = $max; + + return "$_[1] alternation( [\n" . + join( ',', @s ) . + "$_[1] ] )\n"; +} +sub alt1 { &alt } +sub concat { + my @s; + for ( @{$_[0]} ) { + my $tmp = emit_rule( $_, $_[1] ); + push @s, $tmp if $tmp; + } + return + "$_[1] concat( \n" . + join( ',', @s ) . + "$_[1] )\n"; +} +sub code { + return "$_[1] $_[0]\n"; +} +sub dot { + return call_subrule( 'any', $_[1], '' ); +} +sub variable { + my $name = "$_[0]"; + my $value = undef; + # XXX - eval $name doesn't look up in user lexical pad + # XXX - what &xxx interpolate to? + + if ( $name =~ /^\$/ ) { + # $^a, $^b + if ( $name =~ /^ \$ \^ ([^\s]*) /x ) { + my $index = ord($1)-ord('a'); + #print "Variable #$index\n"; + #return "$_[1] constant( \$_[7][$index] )\n"; + + my $code = + " sub { + #print \"Runtime Variable args[\", join(\",\",\@_) ,\"] \$_[7][$index]\\n\"; + return constant( \$_[7][$index] )->(\@_); + }"; + $code =~ s/^/$_[1]/mg; + return "$code\n"; + } + else { + $value = eval $name; + } + } + + # ??? $value = join('', eval $name) if $name =~ /^\@/; + + if ( $name =~ /^%/ ) { + # XXX - runtime or compile-time interpolation? + return "$_[1] hash( \\$name )\n" if $name =~ /::/; + return "$_[1] hash( get_variable( '$name' ) )\n"; + } + die "interpolation of $name not implemented" + unless defined $value; + + return "$_[1] constant( '" . $value . "' )\n"; +} +sub special_char { + my ($char, $data) = $_[0] =~ /^.(.)(.*)/; + + return "$_[1] perl5( '\\N{" . join( "}\\N{", split( /\s*;\s*/, $data ) ) . "}' )\n" + if $char eq 'c'; + return "$_[1] perl5( '(?!\\N{" . join( "}\\N{", split( /\s*;\s*/, $data ) ) . "})\\X' )\n" + if $char eq 'C'; + + return "$_[1] perl5( '\\x{$data}' )\n" + if $char eq 'x'; + return "$_[1] perl5( '(?!\\x{$data})\\X' )\n" + if $char eq 'X'; + + return special_char( sprintf("\\x%X", oct($data) ) ) + if $char eq 'o'; + return special_char( sprintf("\\X%X", oct($data) ) ) + if $char eq 'O'; + + return "$_[1] perl5( '(?:\\n\\r?|\\r\\n?|\\x85|\\x{2028})' )\n" + if $char eq 'n'; + return "$_[1] perl5( '(?!\\n\\r?|\\r\\n?|\\x85|\\x{2028})\\X' )\n" + if $char eq 'N'; + + # XXX - Infinite loop in pugs stdrules.t + #return metasyntax( '?_horizontal_ws', $_[1] ) + return "$_[1] perl5( '[\\x20\\x09]' )\n" + if $char eq 'h'; + return "$_[1] perl5( '[^\\x20\\x09]' )\n" + if $char eq 'H'; + #return metasyntax( '?_vertical_ws', $_[1] ) + return "$_[1] perl5( '[\\x0A\\x0D]' )\n" + if $char eq 'v'; + return "$_[1] perl5( '[^\\x0A\\x0D]' )\n" + if $char eq 'V'; + + for ( qw( r n t e f w d s ) ) { + return "$_[1] perl5( '\\$_' )\n" if $char eq $_; + return "$_[1] perl5( '[^\\$_]' )\n" if $char eq uc($_); + } + $char = '\\\\' if $char eq '\\'; + return "$_[1] constant( q!$char! )\n" unless $char eq '!'; + return "$_[1] constant( q($char) )\n"; +} +sub match_variable { + my $name = $_[0]; + my $num = substr($name,1); + #print "var name: ", $num, "\n"; + my $code = + " sub { + my \$m = \$_[2]; + #print 'var: ',\$m->perl; + #print 'var: ',\$m->[$num]; + return constant( \"\$m->[$num]\" )->(\@_); + }"; + $code =~ s/^/$_[1]/mg; + return "$code\n"; +} +sub closure { + my $code = $_[0]{closure}; + my $modifier = $_[0]{modifier}; # 'plain', '', '?', '!' + + #die "closure modifier not implemented '$modifier'" + # unless $modifier eq 'plain'; + + #warn "CODE $code"; + $code = '' if $code eq '{*}'; # "whatever" + + if ( ref( $code ) + && defined $Pugs::Compiler::Perl6::VERSION + ) { + # perl6 compiler is loaded + $code = Pugs::Emitter::Perl6::Perl5::emit( 'grammar', $code, 'self' ); + $code = '{ my $_V6_SELF = shift; ' . $code . '}'; # make it a "method" + } + else { + # XXX XXX XXX - source-filter - temporary hacks to translate p6 to p5 + # $() + $code =~ s/ ([^']) \$ \( \) < (.*?) > /$1 \$_[0]->[$2]/sgx; + # $ + $code =~ s/ ([^']) \$ < (.*?) > /$1 \$_[0]->{$2}/sgx; + # $() + $code =~ s/ ([^']) \$ \( \) /$1 \$_[0]->()/sgx; + # $/ + $code =~ s/ ([^']) \$ \/ /$1 \$_[0]/sgx; + } + #print "Code: $code\n"; + + return " + sub { + \$_[3] = Pugs::Runtime::Match->new( { + bool => \\1, + str => \\(\$_[0]), + from => \\(\$_[7]{p} || 0), + to => \\(\$_[7]{p} || 0), + match => [], + named => {}, + capture => sub { $code }, + abort => 1, + } ) + }\n" + if $code =~ /return/; + + my $bool = "\\\$::_V6_SUCCEED"; + $bool = "\\( \$capture ? 1 : 0 )" if $modifier eq '?'; + $bool = "\\( \$capture ? 0 : 1 )" if $modifier eq '!'; + + my $cap = "\\\$capture"; + $cap = "undef" if $modifier eq '?' || $modifier eq '!'; + + return " + sub { + \$::_V6_MATCH_ = \$_[0]; + local \$::_V6_SUCCEED = 1; + my \$capture = sub { $code }->( \$_[3] ); + \$_[3] = Pugs::Runtime::Match->new( { + bool => $bool, + str => \\(\$_[0]), + from => \\(\$_[7]{p} || 0), + to => \\(\$_[7]{p} || 0), + match => [], + named => {}, + capture => undef, + } ) + }\n"; + +} +sub named_capture { + my $name = $_[0]{ident}; + $name = $name->{match_variable} if ref($name) eq 'HASH'; + $name =~ s/^[\$\@\%]//; # TODO - change semantics as needed + my $program = $_[0]{rule}; + $capture_seen{$name}++; + return + "$_[1] named( '$name', " . + ( $capture_to_array || ( $capture_seen{$name} > 1 ? 1 : 0 ) ) . + ", \n" . + emit_rule($program, $_[1]) . + "$_[1] )\n"; +} +sub negate { + my $program = $_[0]; + #print "Negate: ", Dumper($_[0]); + return + "$_[1] negate( \n" . + emit_rule($program, $_[1]) . + "$_[1] )\n"; +} +sub before { + my $program = $_[0]{rule}; + return + "$_[1] before( \n" . + emit_rule($program, $_[1]) . + "$_[1] )\n"; +} +sub colon { + my $str = $_[0]; + return "$_[1] at_start() \n" + if $str eq '^'; + return "$_[1] alternation( [ null(), failed_abort() ] ) \n" + if $str eq ':'; + return "$_[1] at_end_of_string() \n" + if $str eq '$'; + return "$_[1] at_line_start() \n" + if $str eq '^^'; + return "$_[1] at_line_end() \n" + if $str eq '$$'; + return metasyntax( '?_wb_left', $_[1] ) + if $str eq '<<'; + return metasyntax( '?_wb_right', $_[1] ) + if $str eq '>>'; + die "'$str' not implemented"; +} +sub modifier { + my $str = $_[0]{modifier}; + my $rule = $_[0]{rule}; + + return "$_[1] ignorecase( \n" + . emit_rule( $rule, $_[1] . ' ' ) + . " )\n" + if $str eq 'ignorecase'; + + die "modifier '$str' not implemented"; +} +sub constant { + my $char = $_[0] eq '\\' ? '\\\\' : $_[0]; + return "$_[1] constant( q!$char! )\n" unless $char =~ /!/; + return "$_[1] constant( q($char) )\n"; +} +sub char_class { + my $cmd = Pugs::Emitter::Rule::Perl5::CharClass::emit( $_[0] ); + return "$_[1] perl5( q!$cmd! )\n" unless $cmd =~ /!/; + return "$_[1] perl5( q($cmd) )\n"; # XXX if $cmd eq '!)' +} +sub call { + #die "not implemented: ", Dumper(\@_); + my $param = $_[0]{params}; + my $name = $_[0]{method}; + # capturing subrule + # + my ($param_list) = $param =~ /\{(.*)\}/; + $param_list = '' unless defined $param_list; + my @param = split( ',', $param_list ); + $capture_seen{$name}++; + #print "subrule ", $capture_seen{$name}, "\n"; + #print "param: ", Dumper(\@param); + return + "$_[1] named( '$name', " . + ( $capture_to_array || ( $capture_seen{$name} > 1 ? 1 : 0 ) ) . + ", \n" . + call_subrule( $name, $_[1]." ", "", @param ) . + "$_[1] )\n"; +} +sub metasyntax { + my $cmd = $_[0]{metasyntax}; + my $modifier = delete $_[0]{modifier} || ''; # ? ! + return negate( { metasyntax => $_[0] }, $_[1] ) if $modifier eq '!'; + + my $prefix = substr( $cmd, 0, 1 ); + if ( $prefix eq '@' ) { + # XXX - wrap @array items - see end of Pugs::Grammar::Rule + return + "$_[1] alternation( \\$cmd )\n"; + } + + if ( $prefix eq '%' ) { + # XXX - runtime or compile-time interpolation? + my $name = substr( $cmd, 1 ); + $capture_seen{$name}++; + return "$_[1] named( '$name', " . + ( $capture_to_array || ( $capture_seen{$name} > 1 ? 1 : 0 ) ) . + ", hash( \\$cmd ) )\n" + if $cmd =~ /::/; + return "$_[1] named( '$name', " . + ( $capture_to_array || ( $capture_seen{$name} > 1 ? 1 : 0 ) ) . + ", hash( get_variable( '$cmd' ) ) )\n"; + } + + if ( $prefix eq '$' ) { + if ( $cmd =~ /::/ ) { + # call method in fully qualified $package::var + return + "$_[1] sub { \n" . + # "$_[1] print 'params: ',Dumper(\@_);\n" . + "$_[1] \$_[3] = $cmd->match( \$_[0], \$_[4], \$_[7], \$_[1] );\n" . + "$_[1] }\n"; + } + # call method in lexical $var + return + "$_[1] sub { \n" . + #"$_[1] print 'params: ',Dumper(\@_);\n" . + "$_[1] my \$r = get_variable( '$cmd' );\n" . + "$_[1] \$_[3] = \$r->match( \$_[0], \$_[4], \$_[7], \$_[1] );\n" . + "$_[1] }\n"; + } + if ( $prefix eq q(') ) { # single quoted literal ' + $cmd = substr( $cmd, 1, -1 ); + return "$_[1] constant( q!$cmd! )\n" unless $cmd =~ /!/; + return "$_[1] constant( q($cmd) )\n"; + } + if ( $prefix eq q(") ) { # interpolated literal " + $cmd = substr( $cmd, 1, -1 ); + warn "<\"...\"> not implemented"; + return; + } + if ( $prefix eq '.' ) { # non_capturing_subrule / code assertion + $cmd = substr( $cmd, 1 ); + if ( $cmd =~ /^{/ ) { + warn "code assertion not implemented"; + return; + } + return call_subrule_no_capture( $cmd, $_[1], '' ); + } + if ( $prefix eq '?' ) { # non_capturing_subrule / code assertion + # XXX FIXME + $cmd = substr( $cmd, 1 ); + if ( $cmd =~ /^{/ ) { + warn "code assertion not implemented"; + return; + } + return call_subrule_no_capture( $cmd, $_[1], '' ); + } + if ( $prefix =~ /[_[:alnum:]]/ ) { + if ( $cmd eq 'cut' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq 'commit' ) { + warn "<$cmd> not implemented"; + return; + } + # capturing subrule + # + my ( $name, $param_list ) = split( /[\(\)]/, $cmd ); + $param_list = '' unless defined $param_list; + my @param = split( ',', $param_list ); + $capture_seen{$name}++; + #print "subrule ", $capture_seen{$name}, "\n"; + #print "param: ", Dumper(\@param); + return + "$_[1] named( '$name', " . + ( $capture_to_array || ( $capture_seen{$name} > 1 ? 1 : 0 ) ) . + ", \n" . + call_subrule( $name, $_[1]." ", "", @param ) . + "$_[1] )\n"; + } + #if ( $prefix eq '.' ) { + # my ( $method, $param_list ) = split( /[\(\)]/, $cmd ); + # $method =~ s/^\.//; + # $param_list ||= ''; + # return "$_[1] try_method( '$method', '$param_list' ) "; + #} + die "<$cmd> not implemented"; +} + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/CharClass.pm b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/CharClass.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/CharClass.pm @@ -0,0 +1,100 @@ +package Pugs::Emitter::Rule::Perl5::CharClass; + +use strict; +use Data::Dumper; + +use vars qw( %char_class ); +BEGIN { + %char_class = map { $_ => 1 } qw( + alpha alnum ascii blank + cntrl digit graph lower + print punct space upper + word xdigit + ); +} + +# input format: +# [ +# '+alpha' +# '-[z]' +# ] + +# TODO - set composition logic +# ( ( ( before +alpha ) | before +digit ) before not-alpha ) before not-digit ) + +sub emit { + #print Dumper( $_[0] ); + #print Dumper( @{$_[0]} ); + my @c = map { "$_" } @{$_[0]}; + #print Dumper( @c ); + my $out = ''; + #my $last_cmd = ''; + for ( @c ) { + my ( $op, $cmd ) = /(.)(.*)/; + + $cmd =~ s/\s//g; + + #if ( $last_cmd eq '-' + # && substr($cmd,0,1) eq '+' + # ) + #{ + # $out .= '|'; + #} + #$last_cmd = substr($cmd,0,1); + + $cmd =~ s/\.\./-/g; # ranges + + # TODO - \o \O + + if ( $cmd =~ /^ \[ \\ c \[ (.*) \] \] /x ) { + #$cmd = "(?:\\N{" . join( "}|\\N{", split( /\s*;\s*/, $1 ) ) . "})"; + $cmd = "[\\N{" . join( "}\\N{", split( /\s*;\s*/, $1 ) ) . "}]"; + } + elsif ( $cmd =~ /^ \[ \\ C \[ (.*) \] \] /x ) { + #$cmd = "(?!\\N{" . join( "}|\\N{", split( /\s*;\s*/, $1 ) ) . "})\\X"; + $cmd = "[^\\N{" . join( "}\\N{", split( /\s*;\s*/, $1 ) ) . "}]"; + } + + + elsif ( $cmd =~ /^ \[ \\ x \[ (.*) \] \] /x ) { + $cmd = "(?:\\x{$1})"; + } + elsif ( $cmd =~ /^ \[ \\ X \[ (.*) \] \] /x ) { + $cmd = "(?!\\x{$1})\\X"; + #$cmd = "[^\\x{$1}]"; + } + + + elsif ( $cmd =~ /^ \s* \[ (.*) /x ) { + $cmd = '[' . $1; + } + elsif ( $cmd =~ /^ \s* (.*) /x ) { + my $name = $1; + $cmd = ( exists $char_class{$name} ) + ? "[[:$name:]]" + : "\\p{$name}"; + } + + if ( $op eq '+' ) { + $out .= + ( $out eq '' ) + ? '(?=' . $cmd . ')' + : '|(?=' . $cmd . ')'; + } + elsif ( $op eq '-' ) { + $out .= '(?!' . $cmd . ')'; + } + else { + #print Dumper( @c ), ' == ', $out, "\n"; + die "invalid character set op: $op"; + } + } + $out = "(?:$out)\\X"; + + #print Dumper( @c ), ' == ', $out, "\n"; + + return $out; +} + +1; + diff --git a/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Ratchet.pm b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Ratchet.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Ratchet.pm @@ -0,0 +1,1152 @@ +package Pugs::Emitter::Rule::Perl5::Ratchet; + +# p6-rule perl5 emitter for ":ratchet" (non-backtracking) +# see: RuleInline.pl, RuleInline-more.pl for a program prototype + +#use Smart::Comments '####'; +use strict; +use warnings; +use Pugs::Emitter::Rule::Perl5::CharClass; +use Data::Dumper; +$Data::Dumper::Indent = 1; + +our $direction = "+"; # XXX make lexical +our $sigspace = 0; +our $capture_count; +our $capture_to_array; +our $RegexPos; + +our $count; +sub id { + if (!defined $count) { + if (defined $::PCR_SEED) { + #warn "SET SEED!!!"; + srand($::PCR_SEED); + } + $count = 1000 + int(rand(1000)); + } + 'I' . ($count++) +} + +sub call_subrule { + my ( $subrule, $tab, $positionals, @param ) = @_; + $subrule = "\$grammar->" . $subrule + unless $subrule =~ / :: | \. | -> /x; + $subrule =~ s/\./->/; # XXX - source filter + + $positionals = shift @param if $positionals eq '' && @param == 1; + + return +"$tab $subrule( \$s, { " + . "p => \$pos, " + . "positionals => [ $positionals ], " + . "args => {" . + join(", ",@param) . + "}, " + . "}, undef )"; +} + +sub quote_constant { + my $const; + if ( $_[0] eq "\\" ) { + $const = "chr(".ord("\\").")"; + } + elsif ( $_[0] eq "'" ) { + $const = "chr(".ord("'").")" + } + else { + $const = "'$_[0]'" + } + return $const; +} + +sub call_constant { + return " 1 # null constant\n" + unless length($_[0]); + my $const = quote_constant( $_[0] ); + my $len = length( eval $const ); + #print "Const: [$_[0]] $const $len \n"; + return +" +$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] ( ( substr( \$s, \$pos, $len ) eq $const ) +$_[1] ? ( \$pos $direction= $len or 1 ) +$_[1] : 0 +$_[1] ) +$_[1] ## \n"; +} + +sub call_perl5 { + my $const = $_[0]; + $_[1] = ' ' unless defined $_[1]; + #print "CONST: $const - $direction \n"; + return +"$_[1] ## +$_[1] ( ( substr( \$s, \$pos ) =~ m/^($const)/ ) +$_[1] ? ( \$pos $direction= length( \$1 ) or 1 ) +$_[1] : 0 +$_[1] ) +$_[1] ## \n"; +} + +sub emit { + my ($grammar, $ast, $param) = @_; + # runtime parameters: $grammar, $string, $state, $arg_list + # rule parameters: see Runtime::Rule.pm + local $sigspace = $param->{sigspace} ? 1 : 0; # XXX - $sigspace should be lexical + ### ratchet emit sigspace: $sigspace + local $capture_count = -1; + local $capture_to_array = 0; + #print "rule: ", Dumper( $ast ); + return + "## +## sigspace: $sigspace +## ratchet: 1 +do { my \$rule; \$rule = sub { + my \$grammar = \$_[0]; + my \$s = \$_[1]; + \$_[3] = \$_[2] unless defined \$_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my \%pad;\n" . + #" my \$pos;\n" . + #" print \"match arg_list = \$_[1]\n\";\n" . + #" print 'match ', Dumper(\\\@_);\n" . + #" print \"match arg_list = \@{[\%{\$_[1]} ]}\n\" if defined \$_[1];\n" . + #" warn \"match pos = \", pos(\$_[1]), \"\\n\";\n" . +" my \$m; + my \$bool; + my \@pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined \$_[3]{p}) { + push \@pos, \$_[3]{p} || 0; + } elsif (\$_[3]{continue}) { + push \@pos, (pos(\$_[1]) || 0) .. length(\$s); + } else { + push \@pos, 0..length(\$s); + } + for my \$pos ( \@pos ) { + my \%index; + my \@match; + my \%named; + \$bool = 1; + \$named{KEY} = \$_[3]{KEY} if exists \$_[3]{KEY}; + \$m = Pugs::Runtime::Match->new( { + str => \\\$s, from => \\(0+\$pos), to => \\(\$pos), + bool => \\\$bool, match => \\\@match, named => \\\%named, capture => undef, + } ); + { + my \$prior = \$::_V6_PRIOR_; + local \$::_V6_PRIOR_ = \$prior; + \$bool = 0 unless +" . + #" do { TAILCALL: ;\n" . + emit_rule( $ast, ' ' ) . "; + } + if ( \$bool ) { + my \$prior = \$::_V6_PRIOR_; + \$::_V6_PRIOR_ = sub { + local \$main::_V6_PRIOR_ = \$prior; + \$rule->(\@_); + }; + #warn \"pos2 = \", \$pos, \"\\n\"; + pos(\$_[1]) = \$pos if \$_[3]{continue}; + last; + } + } # /for + \$::_V6_MATCH_ = \$m; + return \$m; +} } +## \n"; +} + +sub emit_rule { + my $n = $_[0]; + my $tab = $_[1] . ' '; + die "unknown node: ", Dumper( $n ) + unless ref( $n ) eq 'HASH'; + #print "NODE ", Dumper($n); + my @keys = grep { substr($_, 0, 1) ne '_' } keys %$n; + ### Node keys: @keys + my ($k) = @keys; + my $v = $n->{$k}; + local $RegexPos = $n->{_pos}; + ### $RegexPos + if (!defined $RegexPos) { + # warn "WARNING: No _pos slot found for AST node '$k'.\n"; + # warn Dumper($n); + $RegexPos = []; + } + # XXX - use real references + no strict 'refs'; + #print "NODE ", Dumper($k), ", ", Dumper($v); + my $code = $k->( $v, $tab ); + return $code; +} + +#rule nodes + +sub non_capturing_group { + return emit_rule( $_[0], $_[1] ); +} +sub quant { + my $term = $_[0]->{'term'}; + my $quantifier = $_[0]->{quant} || ''; + my $greedy = $_[0]->{greedy} || ''; # + ? + die "greediness control not implemented: $greedy" + if $greedy; + #print "QUANT: ",Dumper($_[0]); + my $id = id(); + my $tab = ( $quantifier eq '' ) ? $_[1] : $_[1] . " "; + my $ws = metasyntax( { metasyntax => 'ws', modifier => '.' }, $tab ); + my $ws3 = ( $sigspace && $_[0]->{ws3} ne '' ) ? " &&\n$ws" : ''; + + my $rul; + { + #print "Term: ", Dumper($term), "\n"; + my $cap = $capture_to_array; + local $capture_to_array = $cap || ( $quantifier ne '' ); + $rul = emit_rule( $term, $tab ); + + # rollback on fail + $rul = "$_[1] ( " + . " ( \$pad{$id} = \$pos or 1 ) &&\n" + . $rul + . " ||" + . " ( ( \$pos = \$pad{$id} ) && 0 )" + . " )"; + } + + $rul = "$ws &&\n$rul" if $sigspace && $_[0]->{ws1} ne ''; + $rul = "$rul &&\n$ws" if $sigspace && $_[0]->{ws2} ne ''; + #print $rul; + return " +$_[1] ## +$_[1] ## pos: @$RegexPos +" . $rul . " +$_[1] ## \n" + if $quantifier eq ''; + # * + ? + # TODO: *? +? ?? + # TODO: *+ ++ ?+ + # TODO: quantifier + capture creates Array + #warn Dumper( $quantifier ); + if ( ref( $quantifier ) eq 'HASH' ) + { + my $code = $quantifier->{closure}; + if ( ref( $code ) ) { + if ( defined $Pugs::Compiler::Perl6::VERSION ) { + #print " perl6 compiler is loaded \n"; + $code = Pugs::Emitter::Perl6::Perl5::emit( 'grammar', $code, 'self' ); + } + }; + my @count = eval $code; + #warn "code: $code = [ @count ]"; + + die "quantifier not implemented: " . Dumper( $quantifier ) + if @count ne 1 + || $count[0] == 0; + + return + "$_[1] ## \n" . + "$_[1] ## pos: @$RegexPos\n" . + "$_[1] (\n" . + join( ' && ', ($rul) x $count[0] ) . + "\n" . + "$_[1] )$ws3\n" . + "$_[1] ## \n"; + } + return + "$_[1] ## \n" . + "$_[1] ## pos: @$RegexPos\n" . + "$_[1] (\n$rul\n" . + "$_[1] || ( \$bool = 1 )\n" . + "$_[1] )$ws3\n" . + "$_[1] ## \n" + if $quantifier eq '?'; + return + "$_[1] ## \n" . + "$_[1] ## pos: @$RegexPos\n" . + "$_[1] do { while (\n$rul) {}; \$bool = 1 }$ws3\n" . + "$_[1] ## \n" + if $quantifier eq '*'; + return + "$_[1] ## \n" . + "$_[1] ## pos: @$RegexPos\n" . + "$_[1] (\n$rul\n" . + "$_[1] && do { while (\n$rul) {}; \$bool = 1 }\n" . + "$_[1] )$ws3\n" . + "$_[1] ## \n" + if $quantifier eq '+'; + die "quantifier not implemented: $quantifier"; +} + +sub alt { + my @s; + # print 'Alt: '; + my $count = $capture_count; + my $max = -1; + my $id = id(); + for ( @{$_[0]} ) { + $capture_count = $count; + my $tmp = emit_rule( $_, $_[1].' ' ); + # print ' ',$capture_count; + $max = $capture_count + if $capture_count > $max; + push @s, $tmp if $tmp; + } + $capture_count = $max; + # print " max = $capture_count\n"; + return + "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] ( +$_[1] ( \$pad{$id} = \$pos or 1 ) +$_[1] && ( +" . join( " +$_[1] ) +$_[1] || ( +$_[1] ( ( \$bool = 1 ) && ( \$pos = \$pad{$id} ) or 1 ) +$_[1] && ", + @s + ) . " +$_[1] ) +$_[1] ) +$_[1] ## \n"; +} +sub alt1 { &alt } +sub conjunctive { + my @s; + # print 'conjunctive: '; + my $count = $capture_count; + my $max = -1; + my $id = id(); + for ( @{$_[0]} ) { + $capture_count = $count; + my $tmp = emit_rule( $_, $_[1].' ' ); + # print ' ',$capture_count; + $max = $capture_count + if $capture_count > $max; + push @s, $tmp if $tmp; + } + $capture_count = $max; + # print " max = $capture_count\n"; + return + "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] ( +$_[1] ( \$pad{$id} = \$pos or 1 ) +$_[1] && ( +" . join( " +$_[1] ) +$_[1] && ( +$_[1] ( ( \$bool = 1 ) && ( \$pos = \$pad{$id} ) or 1 ) +$_[1] && ", + @s + ) . " +$_[1] ) +$_[1] ) +$_[1] ## \n"; +} +sub conjunctive1 { &conjunctive } +sub concat { + my @s; + +=for optimizing + # optimize for the common case of "words" + # Note: this optimization has almost no practical effect + my $is_constant = 0; + for ( @{$_[0]} ) { + if ( ! $sigspace && exists $_->{quant} ) { + my $was_constant = $is_constant; + $is_constant = + $_->{quant}->{quant} eq '' + && exists $_->{quant}->{term}->{constant}; + #print "concat: ", Dumper( $_ ); + if ( $is_constant && $was_constant && $direction ne '-' ) { + $s[-1]->{quant}->{term}->{constant} .= + $_->{quant}->{term}->{constant}; + #print "constant: ",$s[-1]->{quant}->{term}->{constant},"\n"; + next; + } + } + push @s, $_; + } + + for ( @s ) { + $_ = emit_rule( $_, $_[1] ); + } +=cut + + # Try to remove non-greedy quantifiers, by inserting a lookahead; + # cheat: / .*? b / + # into: / [ . ]* b / + # TODO - make it work for '+' quantifier too + for my $i ( 0 .. @{$_[0]} - 1 ) { + if ( exists $_[0][$i]{quant} + && $_[0][$i]{quant}{quant} eq '*' + && $_[0][$i]{quant}{greedy} eq '?' + ) { + my $tmp = { quant => { + %{ $_[0][$i]{quant} }, + greedy => '', quant => '' + }, + _pos => $_[0][$i]{_pos} + }; + $_[0][$i] = { + _pos => $_[0][$i]{_pos}, + quant => { + greedy => '', + quant => $_[0][$i]{quant}{quant}, + ws1 => '', + ws2 => '', + ws3 => '', + term => { + _pos => $_[0][$i]{_pos}, + concat => [ + { + _pos => $_[0][$i]{_pos}, + before => { + rule => { + _pos => $_[0][$i]{_pos}, + concat => [ + @{ $_[0] }[$i+1 .. $#{ $_[0] } ] + ], + }, + modifier => '!', + } + }, + $tmp, + ], + }, + }, + }; + #warn "Quant: ",Dumper($_[0]); + } + } + + for ( @{$_[0]} ) { + my $tmp = emit_rule( $_, $_[1] ); + push @s, $tmp if $tmp; + } + @s = reverse @s if $direction eq '-'; + return +"$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] (\n" . join( "\n$_[1] &&\n", @s ) . " +$_[1] ) +$_[1] ## \n"; +} + +sub code { + return "$_[1] $_[0]\n"; +} + +sub dot { + " +$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] ( substr( \$s, \$pos$direction$direction, 1 ) ne '' ) +$_[1] ## \n" +} + +sub variable { + my $name = "$_[0]"; + my $value = undef; + # XXX - eval $name doesn't look up in user lexical pad + # XXX - what &xxx interpolate to? + + #print "VAR: $name \n"; + # expand embedded $scalar + if ( $name =~ /^\$/ ) { + # $^a, $^b + if ( $name =~ /^ \$ \^ ([^\s]*) /x ) { + my $index = ord($1)-ord('a'); + #print "Variable #$index\n"; + #return "$_[1] constant( \$_[7][$index] )\n"; + + my $code = + " ... sub { + #print \"Runtime Variable args[\", join(\",\",\@_) ,\"] \$_[7][$index]\\n\"; + return constant( \$_[7][$index] )->(\@_); + }"; + $code =~ s/^/$_[1]/mg; + return "$code\n"; + } + + $value = eval $name; + } + + # expand embedded @arrays + if ( $name =~ /^\@/ ) { + my $code = q! + join( + '|', + ! . $name . q! + ) + !; + return +"$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] ( eval( '( substr( \$s, \$pos ) =~ m/^(' . $code . ')/ ) +$_[1] ? ( \$pos $direction= length( \$1 ) or 1 ) +$_[1] : 0 +$_[1] ') ) +$_[1] ## \n"; + } + + # expand embedded %hash + if ( $name =~ /^%/ ) { + my $id = '$' . id(); + my $preprocess_hash = 'Pugs::Runtime::Regex::preprocess_hash'; + my $code = +" + ## + ## pos: @$RegexPos + do { + our $id; + our ${id}_sizes; + unless ( $id ) { + my \$hash = \\$name; + my \%sizes = map { length(\$_) => 1 } keys \%\$hash; + ${id}_sizes = [ sort { \$b <=> \$a } keys \%sizes ]; + " . #print \"sizes: \@${id}_sizes\\n\"; + "$id = \$hash; + } + " . #print 'keys: ',Dumper( $id ); + "my \$match = 0; + my \$key; + for ( \@". $id ."_sizes ) { + \$key = ( \$pos <= length( \$s ) + ? substr( \$s, \$pos, \$_ ) + : '' ); + " . #print \"try ".$name." \$_ = \$key; \$s\\\n\"; + "if ( exists ". $id ."->{\$key} ) { + #\$named{KEY} = \$key; + #\$::_V6_MATCH_ = \$m; + #print \"m: \", Dumper( \$::_V6_MATCH_->data ) + # if ( \$key eq 'until' ); + " . #print \"* ".$name."\{'\$key\'} at \$pos \\\n\"; + "\$match = $preprocess_hash( $id, \$key )->( \$s, \$grammar, { p => ( \$pos + \$_ ), positionals => [ ], args => { KEY => \$key } }, undef ); + " . #print \"match: \", Dumper( \$match->data ); + "last if \$match; + } + } + if ( \$match ) { + \$pos = \$match->to; + #print \"match: \$key at \$pos = \", Dumper( \$match->data ); + \$bool = 1; + }; # else { \$bool = 0 } + \$match; + } + ## +"; + #print $code; + return $code; + } + die "interpolation of $name not implemented" + unless defined $value; + + return call_constant( $value, $_[1] ); +} +sub special_char { + my ($char, $data) = $_[0] =~ /^.(.)(.*)/; + + return call_perl5( '\\N{$data}', $_[1] ) + if $char eq 'c'; + return call_perl5( '(?!\\N{$data}).', $_[1] ) + if $char eq 'C'; + + return call_perl5( '\\x{'.$data.'}', $_[1] ) + if $char eq 'x'; + return call_perl5( '(?!\\x{'.$data.'}).', $_[1] ) + if $char eq 'X'; + + return special_char( sprintf("\\x%X", oct($data) ) ) + if $char eq 'o'; + return special_char( sprintf("\\X%X", oct($data) ) ) + if $char eq 'O'; + + return call_perl5( '(?:\n\r?|\r\n?)', $_[1] ) + if $char eq 'n'; + return call_perl5( '(?!\n\r?|\r\n?).', $_[1] ) + if $char eq 'N'; + + # XXX - Infinite loop in pugs stdrules.t + #return metasyntax( '?_horizontal_ws', $_[1] ) + return call_perl5( '[\x20\x09]' ) + if $char eq 'h'; + return call_perl5( '[^\x20\x09]' ) + if $char eq 'H'; + #return metasyntax( '?_vertical_ws', $_[1] ) + return call_perl5( '[\x0A\x0D]' ) + if $char eq 'v'; + return call_perl5( '[^\x0A\x0D]' ) + if $char eq 'V'; + + for ( qw( r n t e f w d s ) ) { + return call_perl5( "\\$_", $_[1] ) if $char eq $_; + return call_perl5( "[^\\$_]", $_[1] ) if $char eq uc($_); + } + $char = '\\\\' if $char eq '\\'; + ### special char: $char + return call_constant( $char, $_[1] ); +} + +sub match_variable { + my $name = $_[0]; + my $num = substr($name,1); + #print "var name: ", $num, "\n"; + + return +" +$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] ( eval( '( substr( \$s, \$pos ) =~ m/^(' . \$m->{$num} . ')/ ) +$_[1] ? ( \$pos $direction= length( \$1 ) or 1 ) +$_[1] : 0 +$_[1] ') ) +$_[1] ## +"; +} + +sub closure { + #print "closure: ",Dumper($_[0]); + my $code = $_[0]{closure}; + my $modifier = $_[0]{modifier}; # 'plain', '', '?', '!' + + die "invalid closure modifier: . " + if $modifier eq '.'; + + #die "closure modifier not implemented '$modifier'" + # unless $modifier eq 'plain'; + + if ( ref( $code ) + && defined $Pugs::Compiler::Perl6::VERSION + ) { + #print " perl6 compiler is loaded \n"; + $code = Pugs::Emitter::Perl6::Perl5::emit( 'grammar', $code, 'self' ); + $code = '{ my $_V6_SELF = shift; ' . $code . '}'; # make it a "method" + } + else { + #print " perl6 compiler is NOT loaded \n"; + # XXX XXX XXX - source-filter - temporary hacks to translate p6 to p5 + # $() + $code =~ s/ ([^']) \$ \$ (\d+) /$1\${ \$_[0]->[$2] }/sgx; + $code =~ s/ ([^']) \$ (\d+) /$1\$_[0]->[$2]/sgx; + $code =~ s/ ([^']) \$ \( \) < (.*?) > /$1\$_[0]->{$2}/sgx; + # $ + $code =~ s/ ([^']) \$ \$ < (.*?) > /$1\${ \$_[0]->{qw($2)} }/sgx; + $code =~ s/ ([^']) \$ < (.*?) > /$1\$_[0]->{qw($2)}/sgx; + # $() + $code =~ s/ ([^']) \$ \( \) /$1\$_[0]->()/sgx; + # $/ + $code =~ s/ ([^']) \$ \/ ([\{\[]) /$1\$_[0]->$2/sgx; + $code =~ s/ ([^']) \$ \/ /$1\$_[0]/sgx; + #$code =~ s/ use \s+ v6 \s* ; / # use v6\n/sgx; + } + #print "Code: $code\n"; + # "plain" {...return ...} + return + "$_[1] ## \n" + . "$_[1] ## pos: @$RegexPos\n" + . "$_[1] do {\n" + . "$_[1] local \$::_V6_SUCCEED = 1;\n" + . "$_[1] \$::_V6_MATCH_ = \$m;\n" + . "$_[1] \$m->data->{capture} = \\( sub $code->( \$m ) ); \n" + . "$_[1] \$bool = \$::_V6_SUCCEED;\n" + . "$_[1] \$::_V6_MATCH_ = \$m if \$bool; \n" + . "$_[1] return \$m if \$bool; \n" + . "$_[1] }\n" + . "$_[1] ## \n" + if $code =~ /return/; + + # "plain" {...} without return + return + "$_[1] ## \n" + . "$_[1] ## pos: @$RegexPos\n" + . "$_[1] do { \n" + . "$_[1] local \$::_V6_SUCCEED = 1;\n" + . "$_[1] \$::_V6_MATCH_ = \$m;\n" + . "$_[1] sub $code->( \$m );\n" + . "$_[1] 1;\n" + . "$_[1] }\n" + . "$_[1] ## \n" + if $modifier eq 'plain'; + # "?" + return + "$_[1] ## \n" . + "$_[1] ## pos: @$RegexPos\n" . + "$_[1] do { \n" . + "$_[1] local \$::_V6_SUCCEED = 1;\n" . + "$_[1] \$::_V6_MATCH_ = \$m;\n" . + "$_[1] \$bool = ( sub $code->( \$m ) ) ? 1 : 0; \n" . + "$_[1] }" . + "$_[1] ## \n" + if $modifier eq '?'; + # "!" + return + "$_[1] ## \n" . + "$_[1] ## pos: @$RegexPos\n" . + "$_[1] do { \n" . + "$_[1] local \$::_V6_SUCCEED = 1;\n" . + "$_[1] \$::_V6_MATCH_ = \$m;\n" . + "$_[1] \$bool = ( sub $code->( \$m ) ) ? 0 : 1; \n" . + "$_[1] }" . + "$_[1] ## \n" + if $modifier eq '!'; + +} +sub capturing_group { + my $program = $_[0]; + + $capture_count++; + { + local $capture_count = -1; + local $capture_to_array = 0; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + } + + return " +$_[1] ## +$_[1] do{ +$_[1] my \$hash = do { +$_[1] my \$bool = 1; +$_[1] my \$from = \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool = 0 unless +" . $program . "; +$_[1] { str => \\\$s, from => \\\$from, match => \\\@match, named => \\\%named, bool => \\\$bool, to => \\(0+\$pos), capture => undef } +$_[1] }; +$_[1] my \$bool = \${\$hash->{'bool'}};" . + ( $capture_to_array + ? " +$_[1] if ( \$bool ) { +$_[1] push \@{ \$match[ $capture_count ] }, Pugs::Runtime::Match->new( \$hash ); +$_[1] }" + : " +$_[1] \$match[ $capture_count ] = Pugs::Runtime::Match->new( \$hash );" + ) . " +$_[1] \$bool; +$_[1] } +$_[1] ## \n"; +} + +sub capture_as_result { + my $program = $_[0]; + + $capture_count++; + { + local $capture_count = -1; + local $capture_to_array = 0; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + } + return "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do{ +$_[1] my \$hash = do { +$_[1] my \$bool = 1; +$_[1] my \$from = \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool = 0 unless +" . $program . "; +$_[1] { str => \\\$s, from => \\\$from, match => \\\@match, named => \\\%named, bool => \\\$bool, to => \\(0+\$pos), capture => undef } +$_[1] }; +$_[1] my \$bool = \${\$hash->{'bool'}}; +$_[1] \$m->data->{capture} = \\( \"\" . Pugs::Runtime::Match->new( \$hash ) ); +$_[1] \$bool; +$_[1] } +$_[1] ## \n"; +} +sub named_capture { + my $name = $_[0]{ident}; + ### $name + if (ref($name) eq 'HASH') { + $name = $name->{match_variable} || $name->{variable}; + } + $name =~ s/^[\$\@\%]//; # TODO - change semantics as needed + my $program = $_[0]{rule}; + #warn "name [$name]\n"; + + if ( exists $program->{metasyntax} ) { + #print "aliased subrule\n"; + # $/ = $/ + + my $cmd = $program->{metasyntax}{metasyntax}; + die "invalid aliased subrule" + unless $cmd =~ /^[_[:alnum:]]/; + + # + my ( $subrule, $param_list ) = split( /[\(\)]/, $cmd ); + $param_list = '' unless defined $param_list; + my @param = split( ',', $param_list ); + return "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do { + my \$prior = \$::_V6_PRIOR_; + my \$match =\n" . + call_subrule( $subrule, $_[1]." ", "", @param ) . "; + \$::_V6_PRIOR_ = \$prior; + if ( \$match ) {" . + ( $capture_to_array + ? " push \@{\$named{'$name'}}, \$match;" + : " \$named{'$name'} = \$match;" + ) . " + \$pos = \$match->to; + 1 + } + else { 0 } + } +$_[1] ## \n"; + } + elsif ( exists $program->{capturing_group} ) { + #print "aliased capturing_group\n"; + # $/ = $/[0] + { + local $capture_count = -1; + local $capture_to_array = 0; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + } + return "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do{ + my \$match = Pugs::Runtime::Match->new( do { + my \$bool = 1; + my \$from = \$pos; + my \@match; + my \%named; + \$bool = 0 unless " . + $program . "; + { str => \\\$s, from => \\\$from, match => \\\@match, named => \\\%named, bool => \\\$bool, to => \\(0+\$pos), capture => undef } + } ); + if ( \$match ) {" . + ( $capture_to_array + ? " push \@{\$named{'$name'}}, \$match;" + : " \$named{'$name'} = \$match;" + ) . " + \$pos = \$match->to; + 1 + } + else { 0 } + } +$_[1] ## \n"; + } + else { + #print "aliased non_capturing_group\n"; + # $/ = "$/" + #print Dumper( $_[0] ); + $program = emit_rule( $program, $_[1].' ' ); + return "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do{ + my \$from = \$pos; + my \$bool = $program; + my \$match = Pugs::Runtime::Match->new( + { str => \\\$s, from => \\\$from, match => [], named => {}, bool => \\1, to => \\(0+\$pos), capture => undef } + );" . + ( $capture_to_array + ? " push \@{\$named{'$name'}}, \$match;" + : " \$named{'$name'} = \$match;" + ) . " + \$bool + } +$_[1] ## \n"; + } +} +sub negate { + my $program = $_[0]; + #print "Negate: ", Dumper($_[0]); + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + return "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do{ +$_[1] my \$pos1 = \$pos; +$_[1] do { +$_[1] my \$pos = \$pos1; +$_[1] my \$from = \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool = " . $program . " ? 0 : 1; +$_[1] \$bool; +$_[1] }; +$_[1] } +$_[1] ## \n"; +} + +sub before { + my $mod = delete $_[0]{modifier} || ''; + #### before atom: $_[0] + return negate( { before => $_[0], _pos => $_[0]{rule}{_pos}, }, $_[1] ) if $mod eq '!'; + my $program = $_[0]{rule}; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + return " +$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do{ +$_[1] my \$pos1 = \$pos; +$_[1] do { +$_[1] my \$pos = \$pos1; +$_[1] my \$from = \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool = 0 unless +" . $program . "; +$_[1] \$bool; +$_[1] }; +$_[1] } +$_[1] ## \n"; +} + +sub after { + my $mod = delete $_[0]{modifier}; + return negate( { after => $_[0] }, $_[1] ) if $mod eq '!'; + local $direction = "-"; + my $program = $_[0]{rule}; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + return "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do{ +$_[1] my \$pos1 = \$pos; +$_[1] do { +$_[1] my \$pos = \$pos1 - 1; +$_[1] my \$from = \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool = 0 unless +" . $program . "; +$_[1] \$bool; +$_[1] }; +$_[1] } +$_[1] ## \n"; +} + +sub colon { + my $str = $_[0]; + return "$_[1] 1 # : no-op\n" + if $str eq ':'; + return "$_[1] ( \$pos >= length( \$s ) )\n" + if $str eq '$'; + return "$_[1] ( \$pos == 0 )\n" + if $str eq '^'; + + return "$_[1] ( \$pos >= length( \$s ) || substr( \$s, \$pos ) =~ ".'/^(?:\n\r?|\r\n?)/m'." )\n" + if $str eq '$$'; + return "$_[1] ( \$pos == 0 || substr( \$s, 0, \$pos ) =~ ".'/(?:\n\r?|\r\n?)$/m'." )\n" + if $str eq '^^'; + + return metasyntax( { metasyntax => '_wb_left', modifier => '?' }, $_[1] ) + if $str eq '<<'; + return metasyntax( { metasyntax => '_wb_right', modifier => '?' }, $_[1] ) + if $str eq '>>'; + + die "'$str' not implemented"; +} +sub modifier { + my $str = $_[0]; + die "modifier '$str' not implemented"; +} +sub constant { + call_constant( @_ ); +} + +sub char_class { + my $cmd = Pugs::Emitter::Rule::Perl5::CharClass::emit( $_[0] ); + return call_perl5($cmd, $_[1]); +} + +sub call { + #die "not implemented: ", Dumper(\@_); + my $param = $_[0]{params}; + my $name = $_[0]{method}; + # capturing subrule + # + my ($param_list) = $param =~ /\{(.*)\}/; + $param_list = '' unless defined $param_list; + my @param = split( ',', $param_list ); + #print "param: ", Dumper(\@param); + + # TODO + + if ( $name eq 'at' ) { + $param_list ||= 0; # XXX compile-time only + return "$_[1] ( \$pos == $param_list )\n" + } + + return named_capture( + { + ident => $name, + rule => { metasyntax => { metasyntax => $name }, _pos => $_[0]{_pos}, }, + }, + $_[1], + ); +} + +sub metasyntax { + # + #print Dumper(\@_); + my $cmd = $_[0]{metasyntax}; + my $modifier = delete $_[0]{modifier} || ''; # . ? ! + return negate( { metasyntax => $_[0], _pos => $_[0]{_pos} }, $_[1] ) if $modifier eq '!'; + + my $prefix = substr( $cmd, 0, 1 ); + if ( $prefix eq '@' ) { + # XXX - wrap @array items - see end of Pugs::Grammar::Rule + # TODO - param list + my $name = substr( $cmd, 1 ); + return + "$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do { + my \$match; + for my \$subrule ( $cmd ) { + \$match = \$subrule->match( \$s, \$grammar, { p => ( \$pos ), positionals => [ ], args => {} }, undef ); + last if \$match; + } + if ( \$match ) {" . + ( $capture_to_array + ? " push \@{\$named{'$name'}}, \$match;" + : " \$named{'$name'} = \$match;" + ) . " + \$pos = \$match->to; + 1 + } + else { 0 } + } +$_[1] ## \n"; + } + + if ( $prefix eq '%' ) { + # XXX - runtime or compile-time interpolation? + my $name = substr( $cmd, 1 ); + # print "<$cmd>\n"; + # return variable( $cmd ); + return "$_[1]## +$_[1] ## pos: @$RegexPos +$_[1] do{ + my \$match = " . variable( $cmd, $_[1] ) . "; + if ( \$match ) {" . + ( $capture_to_array + ? " push \@{\$named{'$name'}}, \$match;" + : " \$named{'$name'} = \$match;" + ) . " + \$pos = \$match->to; + 1 + } + else { 0 } + }\n$_[1]## \n"; + } + + if ( $prefix eq '$' ) { + if ( $cmd =~ /::/ ) { + # call method in fully qualified $package::var + # ...->match( $rule, $str, $grammar, $flags, $state ) + # TODO - send $pos to subrule + return + "$_[1] ## \n" . + "$_[1] ## pos: @$RegexPos\n" . + "$_[1] do {\n" . + "$_[1] push \@match,\n" . + "$_[1] $cmd->match( \$s, \$grammar, {p => \$pos}, undef );\n" . + "$_[1] \$pos = \$match[-1]->to;\n" . + "$_[1] !\$match[-1] != 1;\n" . + "$_[1] }\n" . + "$_[1] ## \n"; + } + # call method in lexical $var + # TODO - send $pos to subrule + return + "$_[1] ## \n" . + "$_[1] ## pos: @$RegexPos\n" . + "$_[1] do {\n" . + "$_[1] my \$r = Pugs::Runtime::Regex::get_variable( '$cmd' );\n" . + "$_[1] push \@match,\n" . + "$_[1] \$r->match( \$s, \$grammar, {p => \$pos}, undef );\n" . + "$_[1] \$pos = \$match[-1]->to;\n" . + "$_[1] !\$match[-1] != 1;\n" . + "$_[1] }\n" . + "$_[1] ## \n"; + } + if ( $prefix eq q(') ) { # single quoted literal ' + $cmd = substr( $cmd, 1, -1 ); + return call_constant( $cmd, $_[1] ); + } + if ( $prefix eq q(") ) { # interpolated literal " + $cmd = substr( $cmd, 1, -1 ); + warn "<\"...\"> not implemented"; + return; + } + if ( + $modifier eq '.' + || $modifier eq '?' # XXX FIXME + ) + { # non_capturing_subrule / code assertion + #$cmd = substr( $cmd, 1 ); + if ( $cmd =~ /^{/ ) { + warn "code assertion not implemented"; + return; + } + my @param; # TODO + my $subrule = $cmd; + return +"$_[1] ## +$_[1] ## pos: @$RegexPos +$_[1] do { +$_[1] my \$prior = \$::_V6_PRIOR_; +$_[1] my \$match =\n" . + call_subrule( $subrule, $_[1]." ", "", @param ) . "; +$_[1] \$::_V6_PRIOR_ = \$prior; +$_[1] my \$bool = (!\$match != 1); +$_[1] \$pos = \$match->to if \$bool; +$_[1] \$match; +$_[1] } +$_[1] ## \n"; + } + if ( $prefix =~ /[_[:alnum:]]/ ) { + if ( $cmd eq 'cut' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq 'commit' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq 'null' ) { + return "$_[1] 1 # null\n" + } + # + my ( $subrule, $param_list ) = split( /[\(\)]/, $cmd ); + $param_list ||= ''; + + if ( $subrule eq 'at' ) { + $param_list ||= 0; # XXX compile-time only + return "$_[1] ( \$pos == $param_list )\n" + } + + return named_capture( + { + ident => $subrule, + rule => { metasyntax => { metasyntax => $cmd }, _pos => $_[0]->{_pos} }, + }, + $_[1], + ); + } + #### $prefix + #### $modifier + #if ( $prefix eq '.' ) { + # my ( $method, $param_list ) = split( /[\(\)]/, $cmd ); + # $method =~ s/^\.//; + # $param_list ||= ''; + # return " ( \$s->$method( $param_list ) ? 1 : 0 ) "; + #} + die "<$cmd> not implemented"; +} + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Regex.pm b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Regex.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl5/Regex.pm @@ -0,0 +1,250 @@ +package Pugs::Emitter::Rule::Perl5::Regex; + +# p6-rule perl5 emitter for emitting perl5 regexes + +=for TODO + + plug into the :ratchet emitter + + @ (non-)interpolation (test) + aliased, named captures + nested captures + quantified captures + ranges + + die() on captures that would have wrong numbering + +BUGS: + - nested captures are not detected + - set operations on character classes are not detected + +=cut + +use strict; +use warnings; +use Data::Dumper; +$Data::Dumper::Indent = 1; + +our $capture_count; +our $capture_to_array; + +sub emit { + my ($grammar, $ast, $param) = @_; + my $sigspace = $param->{sigspace}; + local $capture_count = -1; + local $capture_to_array = 0; + #print "rule: ", Dumper( $ast ); + die "sigspace not supported in P5 mode (can't call subrule)" + if $sigspace; + my $p5regex = '(?m)' . emit_rule( $ast ); + # print ":P5/$p5regex/ \n"; + return $p5regex; +} + +sub emit_rule { + my $n = $_[0]; + die "unknown node: ", Dumper( $n ) + unless ref( $n ) eq 'HASH'; + #print "NODE ", Dumper($n); + my ($k) = keys %$n; + my $v = $$n{$k}; + # XXX - use real references + no strict 'refs'; + #print "NODE ", Dumper($k), ", ", Dumper($v); + my $code = &$k( $v, '' ); + return $code; +} + +#rule nodes + +sub non_capturing_group { + return "(?:" . emit_rule( $_[0] ) . ")"; +} +sub quant { + my $term = $_[0]->{'term'}; + my $quantifier = $_[0]->{quant} || ''; + my $greedy = $_[0]->{greedy} || ''; # + ? + $greedy = '' if $greedy eq '+'; + #print "QUANT: ",Dumper($_[0]); + # TODO: fix grammar to not emit empty quantifier + die "ranges not implemented" + if ref( $quantifier ); + my $rul; + { + #print "Term: ", Dumper($term), "\n"; + my $cap = $capture_to_array; + local $capture_to_array = $cap || ( $quantifier ne '' ); + $rul = emit_rule( $term ); + } + my $quant = $quantifier . $greedy; + return "(?:$rul)$quant" if $quant; + return $rul; +} +sub alt { + my @s; + my $count = $capture_count; + my $max = -1; + for ( @{$_[0]} ) { + $capture_count = $count; + my $tmp = emit_rule( $_ ); + # print ' ',$capture_count; + $max = $capture_count + if $capture_count > $max; + push @s, $tmp; # if $tmp; + } + $capture_count = $max; + # print " max = $capture_count\n"; + return + "(?:" . join( "|", @s ) . ")"; +} +sub alt1 { &alt } +sub concat { + return join( "", + map { emit_rule( $_ ) } @{$_[0]} + ); +} +sub code { + die "code not implemented"; +} +sub dot { + '(?:\n\r?|\r\n?|.)' +} + +sub variable { + die "variable interpolation not implemented"; +} +sub special_char { + my $char = substr($_[0],1); + return '(?:\n\r?|\r\n?)' + if $char eq 'n'; + return '(?!\n\r?|\r\n?).' + if $char eq 'N'; + for ( qw( r t e f w d s ) ) { + return "\\$_" if $char eq $_; + return "[^\\$_]" if $char eq uc($_); + } + return '\\' . $char; +} +sub match_variable { + die "no match variables yet"; +} +sub closure { + die "no closures"; +} +sub capturing_group { + my $program = $_[0]; + die "capture to array not implemented" + if $capture_to_array; + $capture_count++; + { + local $capture_count = -1; + local $capture_to_array = 0; + $program = emit_rule( $program ) + if ref( $program ); + } + return "(" . $program . ")" +} +sub capture_as_result { + die "return objects not implemented"; +} +sub named_capture { + die "no named captures"; +} +sub negate { + die "no negate"; +} +sub before { + my $program = $_[0]{rule}; + $program = emit_rule( $program ) + if ref( $program ); + return "(?=" . $program . ")"; +} +sub not_before { + my $program = $_[0]{rule}; + $program = emit_rule( $program ) + if ref( $program ); + return "(?!" . $program . ")"; +} +sub after { + my $program = $_[0]{rule}; + $program = emit_rule( $program ) + if ref( $program ); + return "(?<=" . $program . ")"; +} +sub not_after { + my $program = $_[0]{rule}; + $program = emit_rule( $program ) + if ref( $program ); + return "(? 1 } qw( + alpha alnum ascii blank + cntrl digit graph lower + print punct space upper + word xdigit + ); +} + +sub char_class { + my $cmd = Pugs::Emitter::Rule::Perl5::CharClass::emit( $_[0] ); + return $cmd; +} + +sub metasyntax { + # + my $cmd = $_[0]; + my $prefix = substr( $cmd, 0, 1 ); + if ( $prefix eq q(') ) { # single quoted literal ' + $cmd = substr( $cmd, 1, -1 ); + $cmd =~ s/([\$\@\%\[\]\+\*\(\)\?\/])/\\$1/g; + return $cmd; + } + if ( $prefix eq '.' ) { # non_capturing_subrule / code assertion + $cmd = substr( $cmd, 1 ); + if ( exists $char_class{$cmd} ) { + # XXX - inlined char classes are not inheritable, but this should be ok + return "[[:$cmd:]]"; + } + } + if ( $prefix eq '?' ) { # non_capturing_subrule / code assertion + # XXX FIXME + $cmd = substr( $cmd, 1 ); + if ( exists $char_class{$cmd} ) { + # XXX - inlined char classes are not inheritable, but this should be ok + return "[[:$cmd:]]"; + } + } + if ( $prefix =~ /[_[:alnum:]]/ ) { + if ( $cmd eq 'null' ) { + return "" + } + } + die "<$cmd> not implemented"; +} + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl6/Ratchet.pm b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl6/Ratchet.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Emitter/Rule/Perl6/Ratchet.pm @@ -0,0 +1,854 @@ +package Pugs::Emitter::Rule::Perl6::Ratchet; + +# p6-rule perl5 emitter for ":ratchet" (non-backtracking) +# see: RuleInline.pl, RuleInline-more.pl for a program prototype + +use strict; +use warnings; +use Data::Dumper; +$Data::Dumper::Indent = 1; + +our $direction = "+"; # XXX make lexical +our $sigspace = 0; +our $capture_count; +our $capture_to_array; + +our $count = 1000 + int(rand(1000)); +sub id { 'I' . ($count++) } + +# Calling convention: +# $grammar.$rule({ str => '...', pos => $pos, other_arg => $x }) + +=for global vars + + class Grammar::Base { + my $.PRIOR; + } + + Grammar::Base.PRIOR := $rule; + +=cut + +sub call_subrule { + my ( $subrule, $tab, @param ) = @_; + $subrule = "\$grammar." . $subrule + unless $subrule =~ / :: | \. | -> /x; + return +"$tab $subrule( { str => \$str, pos => \$m.to, " . + join(", ",@param) . + " }, undef )"; +} + +sub quote_constant { + my $const; + if ( $_[0] eq "\\" ) { + $const = "chr(".ord("\\").")"; + } + elsif ( $_[0] eq "'" ) { + $const = "chr(".ord("'").")" + } + else { + $const = "'$_[0]'" + } + return $const; +} + +sub call_constant { + return " 1 # null constant\n" + unless length($_[0]); + my $const = quote_constant( $_[0] ); + my $len = length( eval $const ); + #print "Const: [$_[0]] $const $len \n"; + return +"$_[1] ( ( substr( \$str, \$m.to, $len ) eq $const ) +$_[1] ? ( (\$m.to := ( \$m.to $direction $len ) or 1 ) +$_[1] : 0 +$_[1] )"; +} + +sub call_perl5 { + my $const = $_[0]; + #print "CONST: $const - $direction \n"; + return +"$_[1] ( ( substr( \$str, \$m.to ) =~ m:P5/^($const)/ ) +$_[1] ? ( \$m.to := \$m.to $direction length( \$1 ) or 1 ) +$_[1] : 0 +$_[1] )"; +} + +sub emit { + my ($grammar, $ast, $param) = @_; + # runtime parameters: $grammar, $string, $state, $arg_list + # rule parameters: see Runtime::Rule.pm + local $sigspace = $param->{sigspace}; # XXX - $sigspace should be lexical + local $capture_count = -1; + local $capture_to_array = 0; + #print "rule: ", Dumper( $ast ); + return + 'do { my $rule; $rule = method ($grammar: {:$str, :$pos, :$continue, :$KEY}) {' . +" + my \$m; + for ( defined \$pos && ! \$continue + ? \$pos + : ( ( \$pos || 0 ) .. length( \$str ) ) + ) -> \$pos1 { + my \%pad; + my \%named; + \%named{KEY} := \$KEY + if defined \$KEY; + \$m := Pugs::Runtime::Match( { + str => \$str, from => (0+\$pos1), to => \$pos1, + bool => 1, match => [], named => \%named, capture => undef, + } ); + { + my \$prior := Grammar::Base.PRIOR; + temp Grammar::Base.PRIOR := \$prior; + \$m.bool := 0 unless +" . + #" do { TAILCALL: ;\n" . + emit_rule( $ast, ' ' ) . "; + } + if ( \$m.bool ) { + my \$prior := Grammar::Base.PRIOR; + Grammar::Base.PRIOR := sub { + temp Grammar::Base.PRIOR := \$prior; + \$rule.(\@_); + }; + last; + } + } # /for + # Grammar::Base.MATCH := \$m; # this must be set in the caller side + return \$m; +} } +"; +} + +sub emit_rule { + my $n = $_[0]; + my $tab = $_[1] . ' '; + die "unknown node: ", Dumper( $n ) + unless ref( $n ) eq 'HASH'; + #print "NODE ", Dumper($n); + my ($k) = keys %$n; + my $v = $$n{$k}; + # XXX - use real references + no strict 'refs'; + #print "NODE ", Dumper($k), ", ", Dumper($v); + my $code = &$k( $v, $tab ); + return $code; +} + +#rule nodes + +sub non_capturing_group { + return emit_rule( $_[0], $_[1] ); +} +sub quant { + my $term = $_[0]->{'term'}; + my $quantifier = $_[0]->{quant} || ''; + my $greedy = $_[0]->{greedy} || ''; # + ? + die "greediness control not implemented: $greedy" + if $greedy; + #print "QUANT: ",Dumper($_[0]); + # TODO: fix grammar to not emit empty quantifier + my $tab = ( $quantifier eq '' ) ? $_[1] : $_[1] . " "; + my $ws = metasyntax( '?ws', $tab ); + my $ws3 = ( $sigspace && $_[0]->{ws3} ne '' ) ? " &&\n$ws" : ''; + + my $rul; + { + #print "Term: ", Dumper($term), "\n"; + my $cap = $capture_to_array; + local $capture_to_array = $cap || ( $quantifier ne '' ); + $rul = emit_rule( $term, $tab ); + } + + $rul = "$ws &&\n$rul" if $sigspace && $_[0]->{ws1} ne ''; + $rul = "$rul &&\n$ws" if $sigspace && $_[0]->{ws2} ne ''; + #print $rul; + return $rul + if $quantifier eq ''; + # * + ? + # TODO: *? +? ?? + # TODO: *+ ++ ?+ + # TODO: quantifier + capture creates Array + return + "$_[1] (\n$rul\n" . + "$_[1] || ( \$m.bool = 1 )\n" . + "$_[1] ) $ws3" + if $quantifier eq '?'; + return + "$_[1] do { while (\n$rul) {}; \$m.bool := 1 }$ws3" + if $quantifier eq '*'; + return + "$_[1] (\n$rul\n" . + "$_[1] && do { while (\n$rul) {}; \$m.bool := 1 }\n" . + "$_[1] ) $ws3" + if $quantifier eq '+'; + die "quantifier not implemented: $quantifier"; +} +sub alt { + my @s; + # print 'Alt: '; + my $count = $capture_count; + my $max = -1; + my $id = id(); + for ( @{$_[0]} ) { + $capture_count = $count; + my $tmp = emit_rule( $_, $_[1].' ' ); + # print ' ',$capture_count; + $max = $capture_count + if $capture_count > $max; + push @s, $tmp if $tmp; + } + $capture_count = $max; + # print " max = $capture_count\n"; + return + "$_[1] ( +$_[1] ( \%pad{$id} := \$m.to or 1 ) +$_[1] && ( +" . join( " +$_[1] ) +$_[1] || ( +$_[1] ( ( \$m.bool := 1 ) && ( \$m.to := \%pad{$id} ) or 1 ) +$_[1] && ", + @s + ) . " +$_[1] ) +$_[1] )"; +} +sub alt1 { &alt } +sub conjunctive { + my @s; + # print 'conjunctive: '; + my $count = $capture_count; + my $max = -1; + my $id = id(); + for ( @{$_[0]} ) { + $capture_count = $count; + my $tmp = emit_rule( $_, $_[1].' ' ); + # print ' ',$capture_count; + $max = $capture_count + if $capture_count > $max; + push @s, $tmp if $tmp; + } + $capture_count = $max; + # print " max = $capture_count\n"; + return + "$_[1] ( +$_[1] ( \%pad{$id} := \$m.to or 1 ) +$_[1] && ( +" . join( " +$_[1] ) +$_[1] && ( +$_[1] ( ( \$m.bool := 1 ) && ( \$m.to := \%pad{$id} ) or 1 ) +$_[1] && ", + @s + ) . " +$_[1] ) +$_[1] )"; +} +sub concat { + my @s; + +=for optimizing + # optimize for the common case of "words" + # Note: this optimization has almost no practical effect + my $is_constant = 0; + for ( @{$_[0]} ) { + if ( ! $sigspace && exists $_->{quant} ) { + my $was_constant = $is_constant; + $is_constant = + $_->{quant}->{quant} eq '' + && exists $_->{quant}->{term}->{constant}; + #print "concat: ", Dumper( $_ ); + if ( $is_constant && $was_constant && $direction ne '-' ) { + $s[-1]->{quant}->{term}->{constant} .= + $_->{quant}->{term}->{constant}; + #print "constant: ",$s[-1]->{quant}->{term}->{constant},"\n"; + next; + } + } + push @s, $_; + } + + for ( @s ) { + $_ = emit_rule( $_, $_[1] ); + } +=cut + + for ( @{$_[0]} ) { + my $tmp = emit_rule( $_, $_[1] ); + push @s, $tmp if $tmp; + } + @s = reverse @s if $direction eq '-'; + return "$_[1] (\n" . join( "\n$_[1] &&\n", @s ) . "\n$_[1] )"; +} +sub code { + return "$_[1] $_[0]\n"; +} +sub dot { + "$_[1] ( substr( \$s, \$m.to$direction$direction, 1 ) ne '' )" +} + +sub variable { + my $name = "$_[0]"; + my $value = undef; + # XXX - eval $name doesn't look up in user lexical pad + # XXX - what &xxx interpolate to? + + if ( $name =~ /^\$/ ) { + # $^a, $^b + if ( $name =~ /^ \$ \^ ([^\s]*) /x ) { + my $index = ord($1)-ord('a'); + #print "Variable #$index\n"; + #return "$_[1] constant( \$_[7][$index] )\n"; + + my $code = + " ... sub { + #print \"Runtime Variable args[\", join(\",\",\@_) ,\"] \$_[7][$index]\\n\"; + return constant( \$_[7][$index] ).(\@_); + }"; + $code =~ s/^/$_[1]/mg; + return "$code\n"; + } + else { + $value = eval $name; + } + } + + $value = join('', eval $name) if $name =~ /^\@/; + if ( $name =~ /^%/ ) { + my $id = '$' . id(); + my $preprocess_hash = 'Pugs::Runtime::Regex::preprocess_hash'; + my $code = " + do { + state $id; + state ${id}_sizes; + unless ( $id ) { + my \$hash := $name; + my \%sizes := \%\$hash.keys.map:{ .length => 1 }; + ${id}_sizes := [ \%sizes.keys.sort:{ \$^b <=> \$^a } ]; + " . #print \"sizes: \@${id}_sizes\\n\"; + "$id = \$hash; + } + " . #print 'keys: ',Dumper( $id ); + "my \$match := 0; + my \$key; + for \@". $id ."_sizes { + \$key := ( \$m.to <= length( \$s ) + ? substr( \$s, \$m.to, \$_ ) + : '' ); + " . #print \"try ".$name." \$_ = \$key; \$s\\\n\"; + "if ( %". $id .".exists( \$key ) ) { + " . #\$named{KEY} = \$key; + #Grammar::Base.MATCH := \$m; + #print \"m: \", Dumper( Grammar::Base.MATCH ) + # if ( \$key eq 'until' ); + #print \"* ".$name."\{'\$key\'} at \$m.to \\\n\"; + "\$match = $preprocess_hash( $id, \$key ).({ str => \$str, grammar => \$grammar, pos => ( \$m.to + \$_ ), KEY => \$key }); + " . #print \"match: \", Dumper( \$match.data ); + "last if \$match; + } + } + if ( \$match ) { + \$m.to = \$match.to; + " . #print \"match: \$key at \$m.to = \", Dumper( \$match.data ); + "\$match.bool = 1; + }; + \$match; + }"; + #print $code; + return $code; + } + die "interpolation of $name not implemented" + unless defined $value; + + return call_constant( $value, $_[1] ); +} +sub special_char { + my $char = substr($_[0],1); + return call_perl5( '(?:\n\r?|\r\n?)', $_[1] ) + if $char eq 'n'; + return call_perl5( '(?!\n\r?|\r\n?).', $_[1] ) + if $char eq 'N'; + for ( qw( r n t e f w d s ) ) { + return call_perl5( "\\$_", $_[1] ) if $char eq $_; + return call_perl5( "[^\\$_]", $_[1] ) if $char eq uc($_); + } + $char = '\\\\' if $char eq '\\'; + return call_constant( $char, $_[1] ); +} +sub match_variable { + my $name = $_[0]; + my $num = substr($name,1); + #print "var name: ", $num, "\n"; + my $code = + " ... sub { + my \$m = Pugs::Runtime::Match( \$_[2] ); + return constant( \"\$m.[$num]\" ).(\@_); + }"; + $code =~ s/^/$_[1]/mg; + return "$code\n"; +} +sub closure { + my $code = $_[0]; + + if ( ref( $code ) ) { + if ( defined $Pugs::Compiler::Perl6::VERSION ) { + #print " perl6 compiler is loaded \n"; + my $perl5 = Pugs::Emitter::Perl6::Perl5::emit( 'grammar', $code, 'self' ); + return + "do { + temp Grammar::Base.MATCH := \$m; + temp Grammar::Base.SUCCEED := 1; + \$m.capture := sub $perl5.(); + \$m.bool := Grammar::Base.SUCCEED; + Grammar::Base.MATCH := \$m if \$m.bool; + return \$m if \$m.bool; + }" if $perl5 =~ /return/; + return + "do { + Grammar::Base.MATCH := \$m; + temp Grammar::Base.SUCCEED := 1; + sub $perl5.(); + Grammar::Base.SUCCEED; + }"; + } + } + + #print " perl6 compiler is NOT loaded \n"; + #print "Code: $code\n"; + + return + "$_[1] do {\n" . + "$_[1] local Grammar::Base.SUCCEED := 1;\n" . + "$_[1] Grammar::Base.MATCH := \$m;\n" . + "$_[1] sub $code.( \$m );\n" . + "$_[1] Grammar::Base.SUCCEED;\n" . + "$_[1] }" + unless $code =~ /return/; + + return + "$_[1] do { \n" . + "$_[1] local Grammar::Base.SUCCEED := 1;\n" . + "$_[1] Grammar::Base.MATCH := \$m;\n" . + "$_[1] \$m.capture := \\( sub $code.( \$m ) ); \n" . + "$_[1] \$m.bool := Grammar::Base.SUCCEED;\n" . + "$_[1] Grammar::Base.MATCH := \$m if \$m.bool; \n" . + "$_[1] return \$m if \$m.bool; \n" . + "$_[1] }"; + +} +sub capturing_group { + my $program = $_[0]; + + $capture_count++; + { + local $capture_count = -1; + local $capture_to_array = 0; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + } + + return "$_[1] do{ +$_[1] my \$hash := do { +$_[1] my \$bool := 1; +$_[1] my \$from := \$m.to; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool := 0 unless +" . $program . "; +$_[1] { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => (0+\$m.to), capture => undef } +$_[1] }; +$_[1] my \$bool = \$hash.{'bool'};" . + ( $capture_to_array + ? " +$_[1] if ( \$bool ) { +$_[1] push \@( \$match[ $capture_count ] ), Pugs::Runtime::Match( \$hash ); +$_[1] }" + : " +$_[1] \$match[ $capture_count ] = Pugs::Runtime::Match( \$hash );" + ) . " +$_[1] \$bool; +$_[1] }"; +} + +sub capture_as_result { + my $program = $_[0]; + + $capture_count++; + { + local $capture_count = -1; + local $capture_to_array = 0; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + } + return "$_[1] do{ +$_[1] my \$hash := do { +$_[1] my \$bool := 1; +$_[1] my \$from := \$m.to; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool := 0 unless +" . $program . "; +$_[1] { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => (0+\$m.to), capture => undef } +$_[1] }; +$_[1] my \$bool := \$hash.{'bool'}; +$_[1] \$m.capture := ~Pugs::Runtime::Match( \$hash ); +$_[1] \$bool; +$_[1] }"; +} +sub named_capture { + my $name = $_[0]{ident}; + $name = $name->{match_variable} if ref($name) eq 'HASH'; + $name =~ s/^[\$\@\%]//; # TODO - change semantics as needed + my $program = $_[0]{rule}; + #print "name [$name]\n"; + + if ( exists $program->{metasyntax} ) { + #print "aliased subrule\n"; + # $/ = $/ + + my $cmd = $program->{metasyntax}; + die "invalid aliased subrule" + unless $cmd =~ /^[_[:alnum:]]/; + + # + my ( $subrule, $param_list ) = split( /[\(\)]/, $cmd ); + $param_list = '' unless defined $param_list; + my @param = split( ',', $param_list ); + return "$_[1] do { + my \$prior := \$::_V6_PRIOR_; + my \$match := \n" . + call_subrule( $subrule, $_[1]." ", @param ) . "; + \$::_V6_PRIOR_ := \$prior; + if ( \$match ) {" . + ( $capture_to_array + ? " push \@(\$named{'$name'}), \$match;" + : " \$named{'$name'} := \$match;" + ) . " + \$m.to := \$match.to; + 1 + } + else { 0 } + }"; + } + elsif ( exists $program->{capturing_group} ) { + #print "aliased capturing_group\n"; + # $/ = $/[0] + { + local $capture_count = -1; + local $capture_to_array = 0; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + } + return "$_[1] do{ + my \$match := Pugs::Runtime::Match( do { + my \$bool := 1; + my \$from := \$m.to; + my \@match; + my \%named; + \$bool := 0 unless " . + $program . "; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => (0+\$m.to), capture => undef } + } ); + if ( \$match ) {" . + ( $capture_to_array + ? " push \@(\$named{'$name'}), \$match;" + : " \$named{'$name'} := \$match;" + ) . " + \$m.to := \$match.to; + 1 + } + else { 0 } + }"; + } + else { + #print "aliased non_capturing_group\n"; + # $/ = "$/" + #print Dumper( $_[0] ); + $program = emit_rule( $program, $_[1].' ' ); + return "$_[1] do{ + my \$from := \$m.to; + my \$bool := $program; + my \$match := Pugs::Runtime::Match( + { str => \$s, from => \$from, match => [], named => {}, bool => 1, to => (0+\$m.to), capture => undef } + );" . + ( $capture_to_array + ? " push \@(\$named{'$name'}), \$match;" + : " \$named{'$name'} = \$match;" + ) . " + \$bool + }"; + } +} +sub negate { + my $program = $_[0]; + #print "Negate: ", Dumper($_[0]); + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + return "$_[1] do{ +$_[1] my \$pos1 := \$m.to; +$_[1] do { +$_[1] my \$pos := \$pos1; +$_[1] my \$from := \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool := " . $program . " ? 0 : 1; +$_[1] \$bool; +$_[1] }; +$_[1] }"; +} +sub before { + my $program = $_[0]{rule}; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + return "$_[1] do{ +$_[1] my \$pos1 := \$m.to; +$_[1] do { +$_[1] my \$pos := \$pos1; +$_[1] my \$from := \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool := 0 unless +" . $program . "; +$_[1] \$bool; +$_[1] }; +$_[1] }"; +} +sub not_before { + my $program = $_[0]{rule}; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + return "$_[1] do{ +$_[1] my \$pos1 := \$m.to; +$_[1] do { +$_[1] my \$pos := \$pos1; +$_[1] my \$from := \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] my \$bool := 1; +$_[1] \$bool := 0 unless +" . $program . "; +$_[1] ! \$bool; +$_[1] }; +$_[1] }"; +} +sub after { + local $direction = "-"; + my $program = $_[0]{rule}; + $program = emit_rule( $program, $_[1].' ' ) + if ref( $program ); + return "$_[1] do{ +$_[1] my \$pos1 := \$m.to; +$_[1] do { +$_[1] my \$pos := \$pos1 - 1; +$_[1] my \$from := \$pos; +$_[1] my \@match; +$_[1] my \%named; +$_[1] \$bool := 0 unless +" . $program . "; +$_[1] \$bool; +$_[1] }; +$_[1] }"; +} +sub not_after { + warn ' not implemented'; + return; +} +sub colon { + my $str = $_[0]; + return "$_[1] 1 # : no-op\n" + if $str eq ':'; + return "$_[1] ( \$m.to >= length( \$s ) ) \n" + if $str eq '$'; + return "$_[1] ( \$m.to == 0 ) \n" + if $str eq '^'; + + return "$_[1] ( \$m.to >= length( \$s ) || substr( \$s, \$m.to ) =~ /^(?:\n\r?|\r\n?)/m ) \n" + if $str eq '$$'; + return "$_[1] ( \$m.to == 0 || substr( \$s, 0, \$m.to ) =~ /(?:\n\r?|\r\n?)\$/m ) \n" + if $str eq '^^'; + + return metasyntax( '?_wb_left', $_[1] ) + if $str eq '<<'; + return metasyntax( '?_wb_right', $_[1] ) + if $str eq '>>'; + + die "'$str' not implemented"; +} +sub modifier { + my $str = $_[0]; + die "modifier '$str' not implemented"; +} +sub constant { + call_constant( @_ ); +} + +use vars qw( %char_class ); +BEGIN { + %char_class = map { $_ => 1 } qw( + alpha alnum ascii blank + cntrl digit graph lower + print punct space upper + word xdigit + ); +} + +sub metasyntax { + # + my $cmd = $_[0]; + my $prefix = substr( $cmd, 0, 1 ); + if ( $prefix eq '@' ) { + # XXX - wrap @array items - see end of Pugs::Grammar::Rule + # TODO - param list + my $name = substr( $cmd, 1 ); + return + "$_[1] do { + my \$match; + for my \$subrule ( $cmd ) { + \$match := \$subrule.match( \$str, \$grammar, { pos => ( \$m.to ), args => {} }, undef ); + last if \$match; + } + if ( \$match ) {" . + ( $capture_to_array + ? " push \@(\$named{'$name'}), \$match;" + : " \$named{'$name'} := \$match;" + ) . " + \$m.to := \$match.to; + 1 + } + else { 0 } + }"; + } + + if ( $prefix eq '%' ) { + # XXX - runtime or compile-time interpolation? + my $name = substr( $cmd, 1 ); + # print "<$cmd>\n"; + # return variable( $cmd ); + return "$_[1] do{ + my \$match := " . variable( $cmd, $_[1] ) . "; + if ( \$match ) {" . + ( $capture_to_array + ? " push \@{\$named{'$name'}}, \$match;" + : " \$named{'$name'} := \$match;" + ) . " + \$m.to := \$match.to; + 1 + } + else { 0 } + }"; + } + + if ( $prefix eq '$' ) { + if ( $cmd =~ /::/ ) { + # call method in fully qualified $package::var + # ...->match( $rule, $str, $grammar, $flags, $state ) + # TODO - send $pos to subrule + return + "$_[1] do {\n" . + "$_[1] push \@match,\n" . + "$_[1] $cmd.match( \$str, \$grammar, {pod => \$m.to}, undef );\n" . + "$_[1] \$m.to := \$match[-1].to;\n" . + "$_[1] !\$match[-1] != 1;\n" . + "$_[1] }" + } + # call method in lexical $var + return + "$_[1] do {\n" . + "$_[1] my \$r := $cmd;\n" . + "$_[1] push \@match,\n" . + "$_[1] \$r.match( \$str, \$grammar, {pos => \$m.to}, undef );\n" . + "$_[1] \$m.to := \$match[-1].to;\n" . + "$_[1] !\$match[-1] != 1;\n" . + "$_[1] }" + } + if ( $prefix eq q(') ) { # single quoted literal ' + $cmd = substr( $cmd, 1, -1 ); + return call_constant( $cmd, $_[1] ); + } + if ( $prefix eq q(") ) { # interpolated literal " + $cmd = substr( $cmd, 1, -1 ); + warn "<\"...\"> not implemented"; + return; + } + if ( $prefix =~ /[-+[]/ ) { # character class + $cmd =~ s/\.\./-/g; + if ( $prefix eq '-' ) { + $cmd = '[^' . substr($cmd, 2); + } + elsif ( $prefix eq '+' ) { + $cmd = substr($cmd, 2); + } + $cmd =~ s/\s+|\n//g; + # XXX <[^a]> means [\^a] instead of [^a] in perl5re + return call_perl5($cmd, $_[1]); + } + if ( + $prefix eq '.' + || $prefix eq '?' # XXX FIXME + ) + { # non_capturing_subrule / code assertion + $cmd = substr( $cmd, 1 ); + if ( $cmd =~ /^{/ ) { + warn "code assertion not implemented"; + return; + } + if ( exists $char_class{$cmd} ) { + # XXX - inlined char classes are not inheritable, but this should be ok + return call_perl5( "[[:$cmd:]]", $_[1] ); + } + my @param; # TODO + my $subrule = $cmd; + return +"$_[1] do { +$_[1] my \$prior := Grammar::Base.PRIOR; +$_[1] my \$match := \n" . + call_subrule( $subrule, $_[1]." ", @param ) . "; +$_[1] Grammar::Base.PRIOR := \$prior; +$_[1] my \$bool := (!\$match != 1); +$_[1] \$m.to := \$match.to if \$bool; +$_[1] \$match; +$_[1] }"; + } + if ( $prefix =~ /[_[:alnum:]]/ ) { + if ( $cmd eq 'cut' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq 'commit' ) { + warn "<$cmd> not implemented"; + return; + } + if ( $cmd eq 'null' ) { + return "$_[1] 1 # null\n" + } + # + my ( $subrule, $param_list ) = split( /[\(\)]/, $cmd ); + $param_list ||= ''; + + if ( $subrule eq 'at' ) { + $param_list ||= 0; # XXX compile-time only + return "$_[1] ( \$m.to == $param_list )\n" + } + + return named_capture( + { + ident => $subrule, + rule => { metasyntax => $cmd }, + }, + $_[1], + ); + } + #if ( $prefix eq '.' ) { + # my ( $method, $param_list ) = split( /[\(\)]/, $cmd ); + # $method =~ s/^\.//; + # $param_list ||= ''; + # return " ( \$str.$method( $param_list ) ? 1 : 0 ) "; + #} + die "<$cmd> not implemented"; +} + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Grammar/Base.pm b/blib6/pugs/perl5/lib/Pugs/Grammar/Base.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Grammar/Base.pm @@ -0,0 +1,196 @@ +package Pugs::Grammar::Base; +use Pugs::Runtime::Match; +use Pugs::Compiler::RegexPerl5; +use Pugs::Compiler::Regex; +use Data::Dumper; +use Carp; + +use charnames ":full"; # support \c[DIGIT SIX] + +# This class defines , unicode character classes, etc + +# internal methods - not in spec + +sub no_match { + my $grammar = shift; + my $pos = $_[1]{p} || 0; + return Pugs::Runtime::Match->new( { + bool => \0, + str => \$_[0], + match => [], + from => \$pos, + to => \$pos, + capture => undef, + } ); +} + +*fail = \&no_match; + +*any = Pugs::Compiler::RegexPerl5->compile( + '\X' +)->code; + +# <compile( + '\b(?=\w)' +)->code; + +# word>> +*_wb_right = Pugs::Compiler::RegexPerl5->compile( + '(?<=\w)\b' +)->code; + +=for later - unused +# \h +*_horizontal_ws = Pugs::Compiler::RegexPerl5->compile( + #'XXX - Infinite loop in pugs stdrules.t' . + '\x20|\t' + + #'\x0a|\x0b|\x0c|\x0d|\x85' + # from regex_tests, plus \t and ' ' +)->code; + +# \v +*_vertical_ws = Pugs::Compiler::RegexPerl5->compile( + #'XXX - Infinite loop in pugs stdrules.t' . + '[\n\r]' + + #'\x{1680}|\x{180e}|\x{2000}|\x{2001}|\x{2002}|\x{2003}|\x{2004}|\x{2005}|\x{2006}|\x{2007}|\x{2008}|\x{2008}|\x{2009}|\x{200a}|\x{202f}|\x{205f}|\x{3000}' + # from regex_tests +)->code; +=cut + +# specced methods + +sub before { + #print "Base->before: ", Dumper(\@_); + my $grammar = shift; + my $pos = $_[1]{p} || 0; + my $arg = $_[1]{positionals}[0]; + + # XXX - token or regex? + my $rule = Pugs::Compiler::Regex->compile( $arg ); + my $match = $rule->match( $_[0], { pos => $pos } ); + + return Pugs::Runtime::Match->new( { + bool => \( $match ? 1 : 0 ), + str => \$_[0], + match => [], + from => \$pos, + to => \$pos, + capture => undef, + } ); +} + +sub at { + #print "Base->at: ", Dumper(\@_); + my $grammar = shift; + my $pos = $_[1]{p} || 0; + my $arg = $_[1]{positionals}[0]; + # print "at: ",Dumper( @_ ); + return Pugs::Runtime::Match->new( { + bool => \( $pos == $arg ), + str => \$_[0], + match => [], + from => \$pos, + to => \$pos, + capture => undef, + } ); +} + +sub prior { + die "Error: is undefined" + unless defined $main::_V6_PRIOR_; + + my $prior = $main::_V6_PRIOR_; + ## local $main::_V6_PRIOR_; + $prior->(@_[0, 1, 2, 2]); # XXX fix parameter list +} + +*null = Pugs::Compiler::RegexPerl5->compile( + '' +)->code; + +*ws = Pugs::Compiler::RegexPerl5->compile( + '(?:(?code; + +# = word boundary - from regex_tests +*wb = Pugs::Compiler::RegexPerl5->compile( + '\b' +)->code; + +*ident = Pugs::Compiler::RegexPerl5->compile( + '[[:alpha:]_][[:alnum:]_]*' +)->code; + +*name = Pugs::Compiler::RegexPerl5->compile( + # from pugs tests + '(?:[[:alpha:]_][[:alnum:]_]*::)*[[:alpha:]_][[:alnum:]_]*' +)->code; + +*sp = Pugs::Compiler::RegexPerl5->compile( + '\x20' +)->code; + +*dot = Pugs::Compiler::RegexPerl5->compile( + '\.' +)->code; + +*gt = Pugs::Compiler::RegexPerl5->compile( + '>' +)->code; + +*lt = Pugs::Compiler::RegexPerl5->compile( + '<' +)->code; + +#BEGIN { +# # this list was extracted from 'perlre' +# for ( qw( +# alpha alnum ascii blank +# cntrl digit graph lower +# print punct space upper +# word xdigit +# ) ) { +# *{$_} = Pugs::Compiler::RegexPerl5->compile( +# "[[:$_:]]" +# )->code; +# } +#} + +sub DESTROY { } # avoid autoloading this + + sub AUTOLOAD { + #my $self = shift; + my $meth = $AUTOLOAD; + $meth =~ s/.*:://; # strip fully-qualified portion + + # is it a Unicode property? "isL" + { + local $@; + eval ' my $s="a"; $s =~ /\p{' . $meth . '}/ '; + unless ( $@ ) { + *{$meth} = Pugs::Compiler::RegexPerl5->compile( + '\p{' . $meth . '}' + )->code; + return $meth->( @_ ); + } + } + + # is it a char class? "digit" + { + local $@; + eval ' my $s="a"; $s =~ /[[:' . $meth . ':]]/ '; + unless ( $@ ) { + *{$meth} = Pugs::Compiler::RegexPerl5->compile( + '[[:' . $meth . ':]]' + )->code; + return $meth->( @_ ); + } + } + + carp "unknown rule: <$meth>"; + } + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Grammar/Precedence.pm b/blib6/pugs/perl5/lib/Pugs/Grammar/Precedence.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Grammar/Precedence.pm @@ -0,0 +1,349 @@ +package Pugs::Grammar::Precedence; + +# Documentation in the __END__ +use 5.006; +use strict; +use warnings; + +use Parse::Yapp; +use Digest::MD5 'md5_hex'; + +my $cache; +eval { + require Cache::FileCache; + $cache = new Cache::FileCache( { 'namespace' => 'v6-precedence' } ); +}; + +my %relative_precedences = ( + tighter => sub { + splice( @{$_[0]->{levels}}, $_[1], 0, [ $_[2] ] ); + }, + looser => sub { + splice( @{$_[0]->{levels}}, $_[1]+1, 0, [ $_[2] ] ); + }, + equal => sub { + push @{$_[0]->{levels}[$_[1]]}, $_[2]; + }, +); + +# note: S06 - 'chain' can't be mixed with other types in the same level +my %rule_templates = ( + prefix_non => + "'name' exp \n" . + "\t{ \$_[0]->{out}= {fixity => 'prefix', op1 => \$_[1], exp1 => \$_[2],} }", + circumfix_non => + "'name' exp 'name2' \n" . + "\t{ \$_[0]->{out}= {fixity => 'circumfix', op1 => \$_[1], op2 => \$_[3], exp1 => \$_[2],} }\n" . + "\t | 'name' 'name2' \n" . + "\t{ \$_[0]->{out}= {fixity => 'circumfix', op1 => \$_[1], op2 => \$_[2] } }", + infix_right => + "exp 'name' exp \n" . + "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }", + postfix_non => + "exp 'name' \n" . + "\t{ \$_[0]->{out}= {fixity => 'postfix', op1 => \$_[2], exp1 => \$_[1],} }", + postcircumfix_non => + "exp 'name' exp 'name2' \n" . + "\t{ \$_[0]->{out}= {fixity => 'postcircumfix', op1 => \$_[2], op2 => \$_[4], exp1 => \$_[1], exp2 => \$_[3],} } \n" . + "\t | exp 'name' 'name2' \n" . + "\t{ \$_[0]->{out}= {fixity => 'postcircumfix', op1 => \$_[2], op2 => \$_[3], exp1 => \$_[1], } }", + infix_left => + "exp 'name' exp \n" . + "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }", + infix_non => + "exp 'name' exp \n" . + "\t{ \$_[0]->{out}= {fixity => 'infix', op1 => \$_[2], exp1 => \$_[1], exp2 => \$_[3],} }", + ternary_non => + "exp 'name' exp 'name2' exp \n" . + "\t{ \$_[0]->{out}= {fixity => 'ternary', op1 => \$_[2], op2 => \$_[4], exp1 => \$_[1], exp2 => \$_[3], exp3 => \$_[5],} }", + + # XXX + #infix_chain => + # "exp 'name' chain_right \n" . + # "\t{ \$_[0]->{out}= {op1 => 'name', exp1 => \$_[1], exp2 => \$_[3],} }", + #infix_list => + # "exp 'name' list_right \n" . + # "\t{ \$_[0]->{out}= {op1 => 'name', exp1 => \$_[1], exp2 => \$_[3],} }", +); + +sub new { + my $class = shift; + my $self = { levels => [], @_ }; + bless $self, $class; +} + +our $op_count = '000'; +sub add_op { + my ($self, $opt) = @_; + #print "adding $opt->{name}\n"; + $opt->{assoc} = 'non' unless defined $opt->{assoc}; + $opt->{fixity} = 'prefix' unless defined $opt->{fixity}; + $opt->{index} = 'OP' . $op_count++; + #my $fixity = $opt->{fixity}; + #$fixity .= '_' . $opt->{assoc} if $opt->{fixity} eq 'infix'; + for my $level ( 0 .. $#{$self->{levels}} ) { + if ( grep { + defined $opt->{other} + ? ($_->{name} eq $opt->{other}) + : 0 + } @{$self->{levels}[$level]} ) { + #print "pos $level at $opt->{precedence} $opt->{other}\n"; + $relative_precedences{$opt->{precedence}}->($self, $level, $opt); + #print "Precedence table: ", Dump( $self ); + return; + } + } + if ( ! defined $opt->{precedence} ) { + push @{$self->{levels}}, [ $opt ]; + return; + } + die "there is no precedence like ", $opt->{other}; +} + + +sub add_to_list { + my ( $op, $x, $y ) = @_; + my @x = ($x); + @x = @{$x->{list}} if exists $x->{list} && $x->{op1} eq $op; + return { op1 => $op, list => [ @x, $y ], assoc => 'list' }; +} + +sub add_to_chain { + my ( $op, $x, $y ) = @_; + my @x = exists $x->{chain} ? @{$x->{chain}} : ($x); + my @y = exists $y->{chain} ? @{$y->{chain}} : ($y); + return { chain => [ @x, $op, @y ], assoc => 'chain' }; +} + +sub emit_yapp { + my ($self) = @_; + my $s; # = "%{ my \$_[0]->{out}; %}\n"; + my $prec = "P000"; + my %seen; + for my $level ( reverse 0 .. $#{$self->{levels}} ) { + my %assoc; + for my $operator ( @{$self->{levels}[$level]} ) { + push @{$assoc{ $operator->{assoc} }}, $operator; + } + for my $aaa ( keys %assoc ) { + if ( @{$assoc{$aaa}} ) { + my $a = $aaa; + $a = 'nonassoc' if $a eq 'non'; + $a = 'left' if $a eq 'list'; + $a = 'left' if $a eq 'chain'; + $s .= "%$a "; + for my $operator ( @{ $assoc{$aaa} } ) { + next if $seen{$operator->{name}}; + $seen{$operator->{name}} = 1; + $s .= ' ' . + "'$operator->{name}'" ; + # (( $aaa eq 'list' || $aaa eq 'chain' ) + # ? $operator->{index} + # : "'$operator->{name}'" + # ); + } + $s .= + " $prec" . + "\n"; + # $seen{$_->{name}} = 1 for @{$assoc{$_}}; + $prec++; + } + } + } + $s .= "%%\n" . + "statement: exp { return(\$_[0]->{out}) } ;\n"; + + if ( defined $self->{header} ) { + $s .= $self->{header}; + } + else { + $s .= + "exp: NUM { \$_[0]->{out}= \$_[1] }\n"; + } + $prec = "P000"; + for my $level ( reverse 0 .. $#{$self->{levels}} ) { + my %assoc; + for ( @{$self->{levels}[$level]} ) { + push @{$assoc{ $_->{assoc} }}, $_; + } + for ( keys %assoc ) { + if ( @{$assoc{$_}} ) { + + + for my $op ( @{$assoc{$_}} ) { + if ( $op->{assoc} eq 'list' ) { + $s .= + " | exp '$op->{name}' exp %prec $prec\n" . + " { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_list( '$op->{name}', \$_[1], \$_[3] ) } \n" ; + $s .= + " | exp '$op->{name}' %prec $prec\n" . + " { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_list( '$op->{name}', \$_[1], { null => 1 } ) } \n" ; + # " { \$_[0]->{out}= \$_[1] } \n" ; + next; + } + if ( $op->{assoc} eq 'chain' ) { + $s .= + " | exp '$op->{name}' exp %prec $prec\n" . + " { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_chain( '$op->{name}', \$_[1], \$_[3] ) } \n" ; + $s .= + " | exp '$op->{name}' %prec $prec\n" . + " { \$_[0]->{out}= Pugs::Grammar::Precedence::add_to_chain( '$op->{name}', \$_[1], { null => 1 } ) } \n" ; + # " { \$_[0]->{out}= \$_[1] } \n" ; + next; + } + my $t = $rule_templates{"$op->{fixity}_$op->{assoc}"}; + unless ( defined $t ) { + warn "can't find template for '$op->{fixity}_$op->{assoc}'"; + next; + } + $t =~ s/$_/$op->{$_}/g for qw( name2 name ); + $t =~ s/\{ /%prec $prec { /; + $s .= " | $t \n" . + # "\t%prec $prec\n" . + "\t/* $op->{name} $op->{fixity} $op->{assoc} */\n"; + } + $prec++; + } + } + } + $s .= ";\n" . + "%%\n"; + #print $s; + return $s; +} + +sub emit_grammar_perl5 { + my $self = shift; + my $g = $self->emit_yapp(); + #print $g; + + my $digest = md5_hex($self->{grammar} . $g); + my $cached; + + if ($cache && ($cached = $cache->get($digest))) { + return $cached; + } + + my $p = Parse::Yapp->new( input => $g ); + $cached = $p->Output( classname => $self->{grammar} ); + $cache->set($digest, $cached) if $cache; + return $cached; +} + +sub exists_op { die "not implemented" }; +sub delete_op { die "not implemented" }; +sub get_op { die "not implemented" }; +sub inherit_category { die "not implemented" }; +sub inherit_grammar { die "not implemented" }; +sub merge_category { die "not implemented" }; +sub code { die "not implemented" } +sub match { die "not implemented" } +sub perl5 { die "not implemented" } + +1; + +__END__ + +=head1 NAME + +Pugs::Grammar::Precedence - Engine for Perl 6 Rule operator precedence + +=head1 SYNOPSIS + + use Pugs::Grammar::Precedence; + + # example definition for "sub rxinfix:<|> ..." + + my $rxinfix = Pugs::Grammar::Precedence->new( + grammar => 'rxinfix', + ); + $rxinfix->add_op( + name => '|', + assoc => 'left', + fixity => 'infix', + ); + +Pseudo-code for usage inside a grammar: + + sub new_proto( $match ) { + return ${$match}.add_op( + name => $match, + fixity => ..., + precedence => ..., + ); + } + + rule prototype { + proto : + { + return new_proto($/); + } + } + + rule statement { + ... + } + +=head1 DESCRIPTION + +This module provides an implementation for Perl 6 operator precedence. + +=head1 METHODS + +=head2 new () + +Class method. Returns a category object. + +options: + +=over + +=item * C<< grammar => $category_name >> - the name of this category +(a namespace or a Grammar name). + +=back + +=head2 add_op () + +Instance method. Adds a new operator to the category. + +options: + +=over + +=item * name => $operator_name - the name of this operator, such as '+', '*' + +=item * name2 => $operator_name - the name of the second operator in +an operator pair, such as circumfix [ '(', ')' ] or ternary [ '??', '!!' ]. + + # precedence=>'tighter', + # tighter/looser/equiv + # other=>'+', + # fixity => + # infix/prefix/circumfix/postcircumfix/ternary + # assoc => + # left/right/non/chain/list + # rule=>$rule + # (is parsed) + +=back + +=head1 AUTHORS + +The Pugs Team Eperl6-compiler@perl.orgE. + +=head1 SEE ALSO + +Summary of Perl 6 Operators: L + +=head1 COPYRIGHT + +Copyright 2006, 2007 by Flavio Soibelmann Glock and others. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut + diff --git a/blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pm b/blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pm @@ -0,0 +1,3 @@ +# placeholder file - see examples/Grammar.grammar for Rule.pmc's source + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pmc b/blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pmc new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Grammar/Rule.pmc @@ -0,0 +1,15166 @@ +# !!! DO NOT EDIT !!! +# This file was generated by Pugs::Compiler::Rule's compile_p6grammar.pl +# script from examples/Grammar.grammar at Tue Oct 30 11:29:45 2007 + +use strict; +use warnings; + +package Pugs::Grammar::Rule; + +#use base 'Pugs::Grammar::Base'; + +use Pugs::Runtime::Match; +use Pugs::Runtime::Regex; +use Pugs::Runtime::Tracer (); + +# Code block from grammar spec + + +use utf8; +no strict 'refs'; +no warnings 'redefine'; +no warnings 'once'; + +#use Pugs::Runtime::Match; + +our %rule_terms; +our %variables; + + + +# token pod_begin +*pod_begin = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 632 675 + ( + ( $pad{I1170} = $pos or 1 ) + && ( + ## + ## pos: 633 652 + ( + + ## + ## pos: 633 639 + ( ( $pad{I1171} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:\n\r?|\r\n?))/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1171} ) && 0 ) ) + ## + + && + + ## + ## pos: 639 640 + ( ( substr( $s, $pos, 1 ) eq '=' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 640 641 + ( ( substr( $s, $pos, 1 ) eq 'e' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 641 642 + ( ( substr( $s, $pos, 1 ) eq 'n' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 642 644 + ( ( $pad{I1172} = $pos or 1 ) && + + ## + ## pos: 642 643 + ( ( substr( $s, $pos, 1 ) eq 'd' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1172} ) && 0 ) ) + ## + + && + ## + ## pos: 644 652 + do { while ( + ( ( $pad{I1173} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?!\n\r?|\r\n?).)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1173} ) && 0 ) )) {}; $bool = 1 } + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1170} ) or 1 ) + && ## + ## pos: 653 675 + ( + + ## + ## pos: 653 658 + ( ( $pad{I1174} = $pos or 1 ) && + + ## + ## pos: 656 657 + ( substr( $s, $pos++, 1 ) ne '' ) + ## + || ( ( $pos = $pad{I1174} ) && 0 ) ) + ## + + && + ## + ## pos: 658 662 + do { while ( + ( ( $pad{I1175} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?!\n\r?|\r\n?).)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1175} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 662 675 + ( ( $pad{I1176} = $pos or 1 ) && + ## + ## pos: 662 674 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_begin( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1176} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token pod_other +*pod_other = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 700 743 + ( + ( $pad{I1177} = $pos or 1 ) + && ( + ## + ## pos: 701 720 + ( + + ## + ## pos: 701 707 + ( ( $pad{I1178} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:\n\r?|\r\n?))/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1178} ) && 0 ) ) + ## + + && + + ## + ## pos: 707 708 + ( ( substr( $s, $pos, 1 ) eq '=' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 708 709 + ( ( substr( $s, $pos, 1 ) eq 'c' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 709 710 + ( ( substr( $s, $pos, 1 ) eq 'u' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 710 712 + ( ( $pad{I1179} = $pos or 1 ) && + + ## + ## pos: 710 711 + ( ( substr( $s, $pos, 1 ) eq 't' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1179} ) && 0 ) ) + ## + + && + ## + ## pos: 712 720 + do { while ( + ( ( $pad{I1180} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?!\n\r?|\r\n?).)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1180} ) && 0 ) )) {}; $bool = 1 } + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1177} ) or 1 ) + && ## + ## pos: 721 743 + ( + + ## + ## pos: 721 726 + ( ( $pad{I1181} = $pos or 1 ) && + + ## + ## pos: 724 725 + ( substr( $s, $pos++, 1 ) ne '' ) + ## + || ( ( $pos = $pad{I1181} ) && 0 ) ) + ## + + && + ## + ## pos: 726 730 + do { while ( + ( ( $pad{I1182} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?!\n\r?|\r\n?).)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1182} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 730 743 + ( ( $pad{I1183} = $pos or 1 ) && + ## + ## pos: 730 742 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1183} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token ws +*ws = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 761 1059 + ( + ( ( $pad{I1184} = $pos or 1 ) && + ## + ## pos: 762 1056 + ( + ( $pad{I1185} = $pos or 1 ) + && ( + ## + ## pos: 768 783 + ( + + ## + ## pos: 768 775 + ( ( $pad{I1186} = $pos or 1 ) && + + ## + ## pos: 772 774 + ( ( substr( $s, $pos, 1 ) eq '#' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1186} ) && 0 ) ) + ## + + && + ## + ## pos: 775 783 + do { while ( + ( ( $pad{I1187} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?!\n\r?|\r\n?).)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1187} ) && 0 ) )) {}; $bool = 1 } + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1185} ) or 1 ) + && ## + ## pos: 784 1044 + ( + + ## + ## pos: 784 791 + ( ( $pad{I1188} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:\n\r?|\r\n?))/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1188} ) && 0 ) ) + ## + + && + ## + ## pos: 791 1044 + ( + ( ( $pad{I1189} = $pos or 1 ) && + ## + ## pos: 792 1037 + ( + + ## + ## pos: 792 795 + ( ( $pad{I1190} = $pos or 1 ) && + + ## + ## pos: 793 794 + ( ( substr( $s, $pos, 1 ) eq '=' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1190} ) && 0 ) ) + ## + + && + ## + ## pos: 795 1037 + ( + ( ( $pad{I1191} = $pos or 1 ) && + ## + ## pos: 796 1022 + ( + ( $pad{I1192} = $pos or 1 ) + && ( + ## + ## pos: 810 847 + ( + + ## + ## pos: 810 813 + ( ( $pad{I1193} = $pos or 1 ) && + + ## + ## pos: 812 813 + ( ( substr( $s, $pos, 1 ) eq 'b' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1193} ) && 0 ) ) + ## + + && + + ## + ## pos: 813 814 + ( ( substr( $s, $pos, 1 ) eq 'e' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 814 815 + ( ( substr( $s, $pos, 1 ) eq 'g' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 815 816 + ( ( substr( $s, $pos, 1 ) eq 'i' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 816 818 + ( ( $pad{I1194} = $pos or 1 ) && + + ## + ## pos: 816 817 + ( ( substr( $s, $pos, 1 ) eq 'n' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1194} ) && 0 ) ) + ## + + && + + ## + ## pos: 818 824 + ( ( $pad{I1195} = $pos or 1 ) && + ## + ## pos: 818 823 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1195} ) && 0 ) ) + ## + + && + + ## + ## pos: 824 825 + ( ( substr( $s, $pos, 1 ) eq 'E' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 825 826 + ( ( substr( $s, $pos, 1 ) eq 'N' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 826 828 + ( ( $pad{I1196} = $pos or 1 ) && + + ## + ## pos: 826 827 + ( ( substr( $s, $pos, 1 ) eq 'D' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1196} ) && 0 ) ) + ## + + && + ## + ## pos: 828 832 + do { while ( + ( ( $pad{I1197} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?!\n\r?|\r\n?).)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1197} ) && 0 ) )) {}; $bool = 1 } + ## + + && + ## + ## pos: 832 847 + do { while ( + ( ( $pad{I1198} = $pos or 1 ) && + + ## + ## pos: 832 833 + ( substr( $s, $pos++, 1 ) ne '' ) + ## + || ( ( $pos = $pad{I1198} ) && 0 ) )) {}; $bool = 1 } + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 848 882 + ( + + ## + ## pos: 848 851 + ( ( $pad{I1199} = $pos or 1 ) && + + ## + ## pos: 850 851 + ( ( substr( $s, $pos, 1 ) eq 'b' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1199} ) && 0 ) ) + ## + + && + + ## + ## pos: 851 852 + ( ( substr( $s, $pos, 1 ) eq 'e' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 852 853 + ( ( substr( $s, $pos, 1 ) eq 'g' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 853 854 + ( ( substr( $s, $pos, 1 ) eq 'i' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 854 857 + ( ( $pad{I1200} = $pos or 1 ) && + + ## + ## pos: 854 855 + ( ( substr( $s, $pos, 1 ) eq 'n' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1200} ) && 0 ) ) + ## + + && + + ## + ## pos: 857 882 + ( ( $pad{I1201} = $pos or 1 ) && + ## + ## pos: 857 869 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_begin( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1201} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 883 917 + ( + + ## + ## pos: 883 886 + ( ( $pad{I1202} = $pos or 1 ) && + + ## + ## pos: 885 886 + ( ( substr( $s, $pos, 1 ) eq 'k' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1202} ) && 0 ) ) + ## + + && + + ## + ## pos: 886 887 + ( ( substr( $s, $pos, 1 ) eq 'w' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 887 888 + ( ( substr( $s, $pos, 1 ) eq 'i' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 888 892 + ( ( $pad{I1203} = $pos or 1 ) && + + ## + ## pos: 888 889 + ( ( substr( $s, $pos, 1 ) eq 'd' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1203} ) && 0 ) ) + ## + + && + + ## + ## pos: 892 917 + ( ( $pad{I1204} = $pos or 1 ) && + ## + ## pos: 892 904 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1204} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 918 952 + ( + + ## + ## pos: 918 921 + ( ( $pad{I1205} = $pos or 1 ) && + + ## + ## pos: 920 921 + ( ( substr( $s, $pos, 1 ) eq 'p' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1205} ) && 0 ) ) + ## + + && + + ## + ## pos: 921 922 + ( ( substr( $s, $pos, 1 ) eq 'o' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 922 927 + ( ( $pad{I1206} = $pos or 1 ) && + + ## + ## pos: 922 923 + ( ( substr( $s, $pos, 1 ) eq 'd' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1206} ) && 0 ) ) + ## + + && + + ## + ## pos: 927 952 + ( ( $pad{I1207} = $pos or 1 ) && + ## + ## pos: 927 939 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1207} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 953 987 + ( + + ## + ## pos: 953 956 + ( ( $pad{I1208} = $pos or 1 ) && + + ## + ## pos: 955 956 + ( ( substr( $s, $pos, 1 ) eq 'f' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1208} ) && 0 ) ) + ## + + && + + ## + ## pos: 956 957 + ( ( substr( $s, $pos, 1 ) eq 'o' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 957 962 + ( ( $pad{I1209} = $pos or 1 ) && + + ## + ## pos: 957 958 + ( ( substr( $s, $pos, 1 ) eq 'r' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1209} ) && 0 ) ) + ## + + && + + ## + ## pos: 962 987 + ( ( $pad{I1210} = $pos or 1 ) && + ## + ## pos: 962 974 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1210} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 988 1022 + ( + + ## + ## pos: 988 991 + ( ( $pad{I1211} = $pos or 1 ) && + + ## + ## pos: 990 991 + ( ( substr( $s, $pos, 1 ) eq 'h' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1211} ) && 0 ) ) + ## + + && + + ## + ## pos: 991 992 + ( ( substr( $s, $pos, 1 ) eq 'e' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 992 993 + ( ( substr( $s, $pos, 1 ) eq 'a' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 993 994 + ( ( substr( $s, $pos, 1 ) eq 'd' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 994 997 + ( ( $pad{I1212} = $pos or 1 ) && + + ## + ## pos: 994 995 + ( ( substr( $s, $pos, 1 ) eq '1' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1212} ) && 0 ) ) + ## + + && + + ## + ## pos: 997 1022 + ( ( $pad{I1213} = $pos or 1 ) && + ## + ## pos: 997 1009 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1213} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1191} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + ) + ## + || ( ( $pos = $pad{I1189} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1185} ) or 1 ) + && + ## + ## pos: 1045 1056 + ( ( $pad{I1214} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^(\s)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1214} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1184} ) && 0 ) ) + && do { while ( + ( ( $pad{I1184} = $pos or 1 ) && + ## + ## pos: 762 1056 + ( + ( $pad{I1185} = $pos or 1 ) + && ( + ## + ## pos: 768 783 + ( + + ## + ## pos: 768 775 + ( ( $pad{I1186} = $pos or 1 ) && + + ## + ## pos: 772 774 + ( ( substr( $s, $pos, 1 ) eq '#' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1186} ) && 0 ) ) + ## + + && + ## + ## pos: 775 783 + do { while ( + ( ( $pad{I1187} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?!\n\r?|\r\n?).)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1187} ) && 0 ) )) {}; $bool = 1 } + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1185} ) or 1 ) + && ## + ## pos: 784 1044 + ( + + ## + ## pos: 784 791 + ( ( $pad{I1188} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:\n\r?|\r\n?))/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1188} ) && 0 ) ) + ## + + && + ## + ## pos: 791 1044 + ( + ( ( $pad{I1189} = $pos or 1 ) && + ## + ## pos: 792 1037 + ( + + ## + ## pos: 792 795 + ( ( $pad{I1190} = $pos or 1 ) && + + ## + ## pos: 793 794 + ( ( substr( $s, $pos, 1 ) eq '=' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1190} ) && 0 ) ) + ## + + && + ## + ## pos: 795 1037 + ( + ( ( $pad{I1191} = $pos or 1 ) && + ## + ## pos: 796 1022 + ( + ( $pad{I1192} = $pos or 1 ) + && ( + ## + ## pos: 810 847 + ( + + ## + ## pos: 810 813 + ( ( $pad{I1193} = $pos or 1 ) && + + ## + ## pos: 812 813 + ( ( substr( $s, $pos, 1 ) eq 'b' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1193} ) && 0 ) ) + ## + + && + + ## + ## pos: 813 814 + ( ( substr( $s, $pos, 1 ) eq 'e' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 814 815 + ( ( substr( $s, $pos, 1 ) eq 'g' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 815 816 + ( ( substr( $s, $pos, 1 ) eq 'i' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 816 818 + ( ( $pad{I1194} = $pos or 1 ) && + + ## + ## pos: 816 817 + ( ( substr( $s, $pos, 1 ) eq 'n' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1194} ) && 0 ) ) + ## + + && + + ## + ## pos: 818 824 + ( ( $pad{I1195} = $pos or 1 ) && + ## + ## pos: 818 823 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1195} ) && 0 ) ) + ## + + && + + ## + ## pos: 824 825 + ( ( substr( $s, $pos, 1 ) eq 'E' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 825 826 + ( ( substr( $s, $pos, 1 ) eq 'N' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 826 828 + ( ( $pad{I1196} = $pos or 1 ) && + + ## + ## pos: 826 827 + ( ( substr( $s, $pos, 1 ) eq 'D' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1196} ) && 0 ) ) + ## + + && + ## + ## pos: 828 832 + do { while ( + ( ( $pad{I1197} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?!\n\r?|\r\n?).)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1197} ) && 0 ) )) {}; $bool = 1 } + ## + + && + ## + ## pos: 832 847 + do { while ( + ( ( $pad{I1198} = $pos or 1 ) && + + ## + ## pos: 832 833 + ( substr( $s, $pos++, 1 ) ne '' ) + ## + || ( ( $pos = $pad{I1198} ) && 0 ) )) {}; $bool = 1 } + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 848 882 + ( + + ## + ## pos: 848 851 + ( ( $pad{I1199} = $pos or 1 ) && + + ## + ## pos: 850 851 + ( ( substr( $s, $pos, 1 ) eq 'b' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1199} ) && 0 ) ) + ## + + && + + ## + ## pos: 851 852 + ( ( substr( $s, $pos, 1 ) eq 'e' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 852 853 + ( ( substr( $s, $pos, 1 ) eq 'g' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 853 854 + ( ( substr( $s, $pos, 1 ) eq 'i' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 854 857 + ( ( $pad{I1200} = $pos or 1 ) && + + ## + ## pos: 854 855 + ( ( substr( $s, $pos, 1 ) eq 'n' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1200} ) && 0 ) ) + ## + + && + + ## + ## pos: 857 882 + ( ( $pad{I1201} = $pos or 1 ) && + ## + ## pos: 857 869 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_begin( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1201} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 883 917 + ( + + ## + ## pos: 883 886 + ( ( $pad{I1202} = $pos or 1 ) && + + ## + ## pos: 885 886 + ( ( substr( $s, $pos, 1 ) eq 'k' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1202} ) && 0 ) ) + ## + + && + + ## + ## pos: 886 887 + ( ( substr( $s, $pos, 1 ) eq 'w' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 887 888 + ( ( substr( $s, $pos, 1 ) eq 'i' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 888 892 + ( ( $pad{I1203} = $pos or 1 ) && + + ## + ## pos: 888 889 + ( ( substr( $s, $pos, 1 ) eq 'd' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1203} ) && 0 ) ) + ## + + && + + ## + ## pos: 892 917 + ( ( $pad{I1204} = $pos or 1 ) && + ## + ## pos: 892 904 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1204} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 918 952 + ( + + ## + ## pos: 918 921 + ( ( $pad{I1205} = $pos or 1 ) && + + ## + ## pos: 920 921 + ( ( substr( $s, $pos, 1 ) eq 'p' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1205} ) && 0 ) ) + ## + + && + + ## + ## pos: 921 922 + ( ( substr( $s, $pos, 1 ) eq 'o' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 922 927 + ( ( $pad{I1206} = $pos or 1 ) && + + ## + ## pos: 922 923 + ( ( substr( $s, $pos, 1 ) eq 'd' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1206} ) && 0 ) ) + ## + + && + + ## + ## pos: 927 952 + ( ( $pad{I1207} = $pos or 1 ) && + ## + ## pos: 927 939 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1207} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 953 987 + ( + + ## + ## pos: 953 956 + ( ( $pad{I1208} = $pos or 1 ) && + + ## + ## pos: 955 956 + ( ( substr( $s, $pos, 1 ) eq 'f' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1208} ) && 0 ) ) + ## + + && + + ## + ## pos: 956 957 + ( ( substr( $s, $pos, 1 ) eq 'o' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 957 962 + ( ( $pad{I1209} = $pos or 1 ) && + + ## + ## pos: 957 958 + ( ( substr( $s, $pos, 1 ) eq 'r' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1209} ) && 0 ) ) + ## + + && + + ## + ## pos: 962 987 + ( ( $pad{I1210} = $pos or 1 ) && + ## + ## pos: 962 974 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1210} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1192} ) or 1 ) + && ## + ## pos: 988 1022 + ( + + ## + ## pos: 988 991 + ( ( $pad{I1211} = $pos or 1 ) && + + ## + ## pos: 990 991 + ( ( substr( $s, $pos, 1 ) eq 'h' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1211} ) && 0 ) ) + ## + + && + + ## + ## pos: 991 992 + ( ( substr( $s, $pos, 1 ) eq 'e' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 992 993 + ( ( substr( $s, $pos, 1 ) eq 'a' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 993 994 + ( ( substr( $s, $pos, 1 ) eq 'd' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + + && + + ## + ## pos: 994 997 + ( ( $pad{I1212} = $pos or 1 ) && + + ## + ## pos: 994 995 + ( ( substr( $s, $pos, 1 ) eq '1' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1212} ) && 0 ) ) + ## + + && + + ## + ## pos: 997 1022 + ( ( $pad{I1213} = $pos or 1 ) && + ## + ## pos: 997 1009 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->pod_other( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1213} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1191} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + ) + ## + || ( ( $pos = $pad{I1189} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1185} ) or 1 ) + && + ## + ## pos: 1045 1056 + ( ( $pad{I1214} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^(\s)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1214} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1184} ) && 0 ) )) {}; $bool = 1 } + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token ident +*ident = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 1118 1143 + ( + ( ( $pad{I1215} = $pos or 1 ) && + ## + ## pos: 1119 1140 + ( + ( $pad{I1216} = $pos or 1 ) + && ( + + ## + ## pos: 1119 1129 + ( ( $pad{I1217} = $pos or 1 ) && + ## + ## pos: 1120 1128 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1217} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1216} ) or 1 ) + && + ## + ## pos: 1130 1133 + ( ( $pad{I1218} = $pos or 1 ) && + + ## + ## pos: 1131 1132 + ( ( substr( $s, $pos, 1 ) eq '_' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1218} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1216} ) or 1 ) + && + ## + ## pos: 1134 1140 + ( ( $pad{I1219} = $pos or 1 ) && + + ## + ## pos: 1135 1139 + ( ( substr( $s, $pos, 2 ) eq '::' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1219} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1215} ) && 0 ) ) + && do { while ( + ( ( $pad{I1215} = $pos or 1 ) && + ## + ## pos: 1119 1140 + ( + ( $pad{I1216} = $pos or 1 ) + && ( + + ## + ## pos: 1119 1129 + ( ( $pad{I1217} = $pos or 1 ) && + ## + ## pos: 1120 1128 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1217} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1216} ) or 1 ) + && + ## + ## pos: 1130 1133 + ( ( $pad{I1218} = $pos or 1 ) && + + ## + ## pos: 1131 1132 + ( ( substr( $s, $pos, 1 ) eq '_' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1218} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1216} ) or 1 ) + && + ## + ## pos: 1134 1140 + ( ( $pad{I1219} = $pos or 1 ) && + + ## + ## pos: 1135 1139 + ( ( substr( $s, $pos, 2 ) eq '::' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1219} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1215} ) && 0 ) )) {}; $bool = 1 } + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token alnum +*alnum = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 1164 1178 + ( ( $pad{I1220} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[0-9a-zA-Z]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1220} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token alpha +*alpha = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 1199 1210 + ( ( $pad{I1221} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[a-zA-Z]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1221} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token digit +*digit = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 1231 1239 + ( ( $pad{I1222} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[0-9]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1222} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token special_char +*special_char = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 1284 2177 + ( + ( $pad{I1223} = $pos or 1 ) + && ( + ## + ## pos: 1285 1473 + ( + + ## + ## pos: 1285 1296 + ( ( $pad{I1224} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 1287 1294 + ( + ( $pad{I1225} = $pos or 1 ) + && ( + + ## + ## pos: 1287 1290 + ( ( $pad{I1226} = $pos or 1 ) && + + ## + ## pos: 1288 1289 + ( ( substr( $s, $pos, 1 ) eq 'c' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1226} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1225} ) or 1 ) + && + ## + ## pos: 1291 1294 + ( ( $pad{I1227} = $pos or 1 ) && + + ## + ## pos: 1292 1293 + ( ( substr( $s, $pos, 1 ) eq 'C' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1227} ) && 0 ) ) + ## + + ) + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + || ( ( $pos = $pad{I1224} ) && 0 ) ) + ## + + && + + ## + ## pos: 1296 1299 + ( ( $pad{I1228} = $pos or 1 ) && + + ## + ## pos: 1296 1298 + ( ( substr( $s, $pos, 1 ) eq '[' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1228} ) && 0 ) ) + ## + + && + + ## + ## pos: 1299 1340 + ( ( $pad{I1229} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 1300 1338 + ( + ( ( $pad{I1230} = $pos or 1 ) && + ## + ## pos: 1302 1336 + ( + ( $pad{I1231} = $pos or 1 ) + && ( + ## + ## pos: 1302 1309 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'alnum'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && ## + ( ( substr( $s, $pos ) =~ m/^(\s)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && + ## + ## pos: 1313 1318 + ( ( $pad{I1232} = $pos or 1 ) && + + ## + ## pos: 1314 1317 + ( ( substr( $s, $pos, 1 ) eq ';' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1232} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && + ## + ## pos: 1319 1324 + ( ( $pad{I1233} = $pos or 1 ) && + + ## + ## pos: 1320 1323 + ( ( substr( $s, $pos, 1 ) eq '(' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1233} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && + ## + ## pos: 1325 1330 + ( ( $pad{I1234} = $pos or 1 ) && + + ## + ## pos: 1326 1329 + ( ( substr( $s, $pos, 1 ) eq ')' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1234} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && + ## + ## pos: 1331 1336 + ( ( $pad{I1235} = $pos or 1 ) && + + ## + ## pos: 1332 1335 + ( ( substr( $s, $pos, 1 ) eq '-' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1235} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1230} ) && 0 ) ) + && do { while ( + ( ( $pad{I1230} = $pos or 1 ) && + ## + ## pos: 1302 1336 + ( + ( $pad{I1231} = $pos or 1 ) + && ( + ## + ## pos: 1302 1309 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'alnum'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && ## + ( ( substr( $s, $pos ) =~ m/^(\s)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && + ## + ## pos: 1313 1318 + ( ( $pad{I1232} = $pos or 1 ) && + + ## + ## pos: 1314 1317 + ( ( substr( $s, $pos, 1 ) eq ';' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1232} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && + ## + ## pos: 1319 1324 + ( ( $pad{I1233} = $pos or 1 ) && + + ## + ## pos: 1320 1323 + ( ( substr( $s, $pos, 1 ) eq '(' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1233} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && + ## + ## pos: 1325 1330 + ( ( $pad{I1234} = $pos or 1 ) && + + ## + ## pos: 1326 1329 + ( ( substr( $s, $pos, 1 ) eq ')' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1234} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1231} ) or 1 ) + && + ## + ## pos: 1331 1336 + ( ( $pad{I1235} = $pos or 1 ) && + + ## + ## pos: 1332 1335 + ( ( substr( $s, $pos, 1 ) eq '-' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1235} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1230} ) && 0 ) )) {}; $bool = 1 } + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 1 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + || ( ( $pos = $pad{I1229} ) && 0 ) ) + ## + + && + + ## + ## pos: 1340 1385 + ( ( $pad{I1236} = $pos or 1 ) && + + ## + ## pos: 1340 1342 + ( ( substr( $s, $pos, 1 ) eq ']' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1236} ) && 0 ) ) + ## + + && + + ## + ## pos: 1385 1473 + ( ( $pad{I1237} = $pos or 1 ) && + ## + ## pos: 1385 1463 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { special_char => '\\' . $_[0]->[0] . $_[0]->[1], _pos => [$_[0]->from - 1, $_[0]->to] }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1237} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1223} ) or 1 ) + && ## + ## pos: 1474 1617 + ( + + ## + ## pos: 1474 1485 + ( ( $pad{I1238} = $pos or 1 ) && + ## + ## pos: 1476 1483 + ( + ( $pad{I1239} = $pos or 1 ) + && ( + + ## + ## pos: 1476 1479 + ( ( $pad{I1240} = $pos or 1 ) && + + ## + ## pos: 1477 1478 + ( ( substr( $s, $pos, 1 ) eq 'x' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1240} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1239} ) or 1 ) + && + ## + ## pos: 1480 1483 + ( ( $pad{I1241} = $pos or 1 ) && + + ## + ## pos: 1481 1482 + ( ( substr( $s, $pos, 1 ) eq 'X' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1241} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1238} ) && 0 ) ) + ## + + && + ## + ## pos: 1485 1535 + ( + ( ( $pad{I1242} = $pos or 1 ) && + ## + ## pos: 1485 1493 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->xdigit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'xdigit'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1242} ) && 0 ) ) + && do { while ( + ( ( $pad{I1242} = $pos or 1 ) && + ## + ## pos: 1485 1493 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->xdigit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'xdigit'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1242} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 1535 1617 + ( ( $pad{I1243} = $pos or 1 ) && + ## + ## pos: 1535 1608 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { special_char => '\\' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to] }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1243} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1223} ) or 1 ) + && ## + ## pos: 1618 1777 + ( + + ## + ## pos: 1618 1629 + ( ( $pad{I1244} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 1620 1627 + ( + ( $pad{I1245} = $pos or 1 ) + && ( + + ## + ## pos: 1620 1623 + ( ( $pad{I1246} = $pos or 1 ) && + + ## + ## pos: 1621 1622 + ( ( substr( $s, $pos, 1 ) eq 'x' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1246} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1245} ) or 1 ) + && + ## + ## pos: 1624 1627 + ( ( $pad{I1247} = $pos or 1 ) && + + ## + ## pos: 1625 1626 + ( ( substr( $s, $pos, 1 ) eq 'X' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1247} ) && 0 ) ) + ## + + ) + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + || ( ( $pos = $pad{I1244} ) && 0 ) ) + ## + + && + + ## + ## pos: 1629 1632 + ( ( $pad{I1248} = $pos or 1 ) && + + ## + ## pos: 1629 1631 + ( ( substr( $s, $pos, 1 ) eq '[' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1248} ) && 0 ) ) + ## + + && + + ## + ## pos: 1632 1644 + ( ( $pad{I1249} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 1633 1642 + ( + ( ( $pad{I1250} = $pos or 1 ) && + ## + ## pos: 1633 1641 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->xdigit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'xdigit'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1250} ) && 0 ) ) + && do { while ( + ( ( $pad{I1250} = $pos or 1 ) && + ## + ## pos: 1633 1641 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->xdigit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'xdigit'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1250} ) && 0 ) )) {}; $bool = 1 } + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 1 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + || ( ( $pos = $pad{I1249} ) && 0 ) ) + ## + + && + + ## + ## pos: 1644 1689 + ( ( $pad{I1251} = $pos or 1 ) && + + ## + ## pos: 1644 1646 + ( ( substr( $s, $pos, 1 ) eq ']' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1251} ) && 0 ) ) + ## + + && + + ## + ## pos: 1689 1777 + ( ( $pad{I1252} = $pos or 1 ) && + ## + ## pos: 1689 1767 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { special_char => '\\' . $_[0]->[0] . $_[0]->[1], _pos => [$_[0]->from - 1, $_[0]->to] }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1252} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1223} ) or 1 ) + && ## + ## pos: 1778 1915 + ( + + ## + ## pos: 1778 1789 + ( ( $pad{I1253} = $pos or 1 ) && + ## + ## pos: 1780 1787 + ( + ( $pad{I1254} = $pos or 1 ) + && ( + + ## + ## pos: 1780 1783 + ( ( $pad{I1255} = $pos or 1 ) && + + ## + ## pos: 1781 1782 + ( ( substr( $s, $pos, 1 ) eq 'o' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1255} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1254} ) or 1 ) + && + ## + ## pos: 1784 1787 + ( ( $pad{I1256} = $pos or 1 ) && + + ## + ## pos: 1785 1786 + ( ( substr( $s, $pos, 1 ) eq 'O' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1256} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1253} ) && 0 ) ) + ## + + && + ## + ## pos: 1789 1833 + ( + ( ( $pad{I1257} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^(\d)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1257} ) && 0 ) ) + && do { while ( + ( ( $pad{I1257} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^(\d)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1257} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 1833 1915 + ( ( $pad{I1258} = $pos or 1 ) && + ## + ## pos: 1833 1906 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { special_char => '\\' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to] }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1258} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1223} ) or 1 ) + && ## + ## pos: 1916 2069 + ( + + ## + ## pos: 1916 1927 + ( ( $pad{I1259} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 1918 1925 + ( + ( $pad{I1260} = $pos or 1 ) + && ( + + ## + ## pos: 1918 1921 + ( ( $pad{I1261} = $pos or 1 ) && + + ## + ## pos: 1919 1920 + ( ( substr( $s, $pos, 1 ) eq 'o' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1261} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1260} ) or 1 ) + && + ## + ## pos: 1922 1925 + ( ( $pad{I1262} = $pos or 1 ) && + + ## + ## pos: 1923 1924 + ( ( substr( $s, $pos, 1 ) eq 'O' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1262} ) && 0 ) ) + ## + + ) + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + || ( ( $pos = $pad{I1259} ) && 0 ) ) + ## + + && + + ## + ## pos: 1927 1930 + ( ( $pad{I1263} = $pos or 1 ) && + + ## + ## pos: 1927 1929 + ( ( substr( $s, $pos, 1 ) eq '[' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1263} ) && 0 ) ) + ## + + && + + ## + ## pos: 1930 1936 + ( ( $pad{I1264} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 1931 1934 + ( + ( ( $pad{I1265} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^(\d)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1265} ) && 0 ) ) + && do { while ( + ( ( $pad{I1265} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^(\d)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1265} ) && 0 ) )) {}; $bool = 1 } + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 1 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + || ( ( $pos = $pad{I1264} ) && 0 ) ) + ## + + && + + ## + ## pos: 1936 1981 + ( ( $pad{I1266} = $pos or 1 ) && + + ## + ## pos: 1936 1938 + ( ( substr( $s, $pos, 1 ) eq ']' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1266} ) && 0 ) ) + ## + + && + + ## + ## pos: 1981 2069 + ( ( $pad{I1267} = $pos or 1 ) && + ## + ## pos: 1981 2059 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { special_char => '\\' . $_[0]->[0] . $_[0]->[1], _pos => [$_[0]->from - 1, $_[0]->to] }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1267} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1223} ) or 1 ) + && ## + ## pos: 2070 2177 + ( + + ## + ## pos: 2070 2103 + ( ( $pad{I1268} = $pos or 1 ) && + + ## + ## pos: 2071 2072 + ( substr( $s, $pos++, 1 ) ne '' ) + ## + || ( ( $pos = $pad{I1268} ) && 0 ) ) + ## + + && + + ## + ## pos: 2103 2177 + ( ( $pad{I1269} = $pos or 1 ) && + ## + ## pos: 2103 2176 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { special_char => '\\' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to] }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1269} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token literal +*literal = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 2200 2251 + do { while ( + ( ( $pad{I1270} = $pos or 1 ) && + ## + ## pos: 2201 2248 + ( + ( $pad{I1271} = $pos or 1 ) + && ( + ## + ## pos: 2207 2231 + ( + + ## + ## pos: 2207 2212 + ( ( $pad{I1272} = $pos or 1 ) && + + ## + ## pos: 2209 2211 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1272} ) && 0 ) ) + ## + + && + + ## + ## pos: 2212 2231 + ( ( $pad{I1273} = $pos or 1 ) && + ## + ## pos: 2212 2226 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1273} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1271} ) or 1 ) + && + ## + ## pos: 2232 2248 + ( ( $pad{I1274} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\']))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1274} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1270} ) && 0 ) )) {}; $bool = 1 } + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token double_quoted +*double_quoted = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 2280 2372 + do { while ( + ( ( $pad{I1275} = $pos or 1 ) && + ## + ## pos: 2281 2369 + ( + ( $pad{I1276} = $pos or 1 ) + && ( + ## + ## pos: 2287 2311 + ( + + ## + ## pos: 2287 2292 + ( ( $pad{I1277} = $pos or 1 ) && + + ## + ## pos: 2289 2291 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1277} ) && 0 ) ) + ## + + && + + ## + ## pos: 2292 2311 + ( ( $pad{I1278} = $pos or 1 ) && + ## + ## pos: 2292 2306 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1278} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1276} ) or 1 ) + && + ## + ## pos: 2312 2352 + ( ( $pad{I1279} = $pos or 1 ) && + ## + ## pos: 2314 2347 + do{ + my $match = + ## + ## pos: 2314 2347 + do { + our $I1280; + our $I1280_sizes; + unless ( $I1280 ) { + my $hash = \%Pugs::Grammar::Rule::variables; + my %sizes = map { length($_) => 1 } keys %$hash; + $I1280_sizes = [ sort { $b <=> $a } keys %sizes ]; + $I1280 = $hash; + } + my $match = 0; + my $key; + for ( @$I1280_sizes ) { + $key = ( $pos <= length( $s ) + ? substr( $s, $pos, $_ ) + : '' ); + if ( exists $I1280->{$key} ) { + #$named{KEY} = $key; + #$::_V6_MATCH_ = $m; + #print "m: ", Dumper( $::_V6_MATCH_->data ) + # if ( $key eq 'until' ); + $match = Pugs::Runtime::Regex::preprocess_hash( $I1280, $key )->( $s, $grammar, { p => ( $pos + $_ ), positionals => [ ], args => { KEY => $key } }, undef ); + last if $match; + } + } + if ( $match ) { + $pos = $match->to; + #print "match: $key at $pos = ", Dumper( $match->data ); + $bool = 1; + }; # else { $bool = 0 } + $match; + } + ## + ; + if ( $match ) { push @{$named{'Pugs::Grammar::Rule::variables'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1279} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1276} ) or 1 ) + && + ## + ## pos: 2353 2369 + ( ( $pad{I1281} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\"]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1281} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1275} ) && 0 ) )) {}; $bool = 1 } + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token metasyntax +*metasyntax = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 2398 2576 + ( + ( ( $pad{I1282} = $pos or 1 ) && + ## + ## pos: 2399 2573 + ( + ( $pad{I1283} = $pos or 1 ) + && ( + ## + ## pos: 2405 2429 + ( + + ## + ## pos: 2405 2410 + ( ( $pad{I1284} = $pos or 1 ) && + + ## + ## pos: 2407 2409 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1284} ) && 0 ) ) + ## + + && + + ## + ## pos: 2410 2429 + ( ( $pad{I1285} = $pos or 1 ) && + ## + ## pos: 2410 2424 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1285} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && ## + ## pos: 2430 2458 + ( + + ## + ## pos: 2430 2436 + ( ( $pad{I1286} = $pos or 1 ) && + + ## + ## pos: 2432 2434 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1286} ) && 0 ) ) + ## + + && + + ## + ## pos: 2436 2451 + ( ( $pad{I1287} = $pos or 1 ) && + ## + ## pos: 2436 2446 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->literal( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1287} ) && 0 ) ) + ## + + && + + ## + ## pos: 2451 2458 + ( ( $pad{I1288} = $pos or 1 ) && + + ## + ## pos: 2451 2453 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1288} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && ## + ## pos: 2459 2491 + ( + + ## + ## pos: 2459 2465 + ( ( $pad{I1289} = $pos or 1 ) && + + ## + ## pos: 2461 2463 + ( ( substr( $s, $pos, 1 ) eq '"' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1289} ) && 0 ) ) + ## + + && + + ## + ## pos: 2465 2484 + ( ( $pad{I1290} = $pos or 1 ) && + ## + ## pos: 2465 2481 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->double_quoted( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1290} ) && 0 ) ) + ## + + && + + ## + ## pos: 2484 2491 + ( ( $pad{I1291} = $pos or 1 ) && + + ## + ## pos: 2484 2486 + ( ( substr( $s, $pos, 1 ) eq '"' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1291} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && ## + ## pos: 2492 2527 + ( + + ## + ## pos: 2492 2498 + ( ( $pad{I1292} = $pos or 1 ) && + + ## + ## pos: 2494 2496 + ( ( substr( $s, $pos, 1 ) eq '{' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1292} ) && 0 ) ) + ## + + && + + ## + ## pos: 2498 2520 + ( ( $pad{I1293} = $pos or 1 ) && + ## + ## pos: 2498 2512 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1293} ) && 0 ) ) + ## + + && + + ## + ## pos: 2520 2527 + ( ( $pad{I1294} = $pos or 1 ) && + + ## + ## pos: 2520 2522 + ( ( substr( $s, $pos, 1 ) eq '}' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1294} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && ## + ## pos: 2528 2556 + ( + + ## + ## pos: 2528 2534 + ( ( $pad{I1295} = $pos or 1 ) && + + ## + ## pos: 2530 2532 + ( ( substr( $s, $pos, 1 ) eq '<' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1295} ) && 0 ) ) + ## + + && + + ## + ## pos: 2534 2549 + ( ( $pad{I1296} = $pos or 1 ) && + ## + ## pos: 2534 2547 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->metasyntax( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1296} ) && 0 ) ) + ## + + && + + ## + ## pos: 2549 2556 + ( ( $pad{I1297} = $pos or 1 ) && + + ## + ## pos: 2549 2551 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1297} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && + ## + ## pos: 2557 2573 + ( ( $pad{I1298} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\>]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1298} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1282} ) && 0 ) ) + && do { while ( + ( ( $pad{I1282} = $pos or 1 ) && + ## + ## pos: 2399 2573 + ( + ( $pad{I1283} = $pos or 1 ) + && ( + ## + ## pos: 2405 2429 + ( + + ## + ## pos: 2405 2410 + ( ( $pad{I1284} = $pos or 1 ) && + + ## + ## pos: 2407 2409 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1284} ) && 0 ) ) + ## + + && + + ## + ## pos: 2410 2429 + ( ( $pad{I1285} = $pos or 1 ) && + ## + ## pos: 2410 2424 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1285} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && ## + ## pos: 2430 2458 + ( + + ## + ## pos: 2430 2436 + ( ( $pad{I1286} = $pos or 1 ) && + + ## + ## pos: 2432 2434 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1286} ) && 0 ) ) + ## + + && + + ## + ## pos: 2436 2451 + ( ( $pad{I1287} = $pos or 1 ) && + ## + ## pos: 2436 2446 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->literal( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1287} ) && 0 ) ) + ## + + && + + ## + ## pos: 2451 2458 + ( ( $pad{I1288} = $pos or 1 ) && + + ## + ## pos: 2451 2453 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1288} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && ## + ## pos: 2459 2491 + ( + + ## + ## pos: 2459 2465 + ( ( $pad{I1289} = $pos or 1 ) && + + ## + ## pos: 2461 2463 + ( ( substr( $s, $pos, 1 ) eq '"' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1289} ) && 0 ) ) + ## + + && + + ## + ## pos: 2465 2484 + ( ( $pad{I1290} = $pos or 1 ) && + ## + ## pos: 2465 2481 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->double_quoted( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1290} ) && 0 ) ) + ## + + && + + ## + ## pos: 2484 2491 + ( ( $pad{I1291} = $pos or 1 ) && + + ## + ## pos: 2484 2486 + ( ( substr( $s, $pos, 1 ) eq '"' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1291} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && ## + ## pos: 2492 2527 + ( + + ## + ## pos: 2492 2498 + ( ( $pad{I1292} = $pos or 1 ) && + + ## + ## pos: 2494 2496 + ( ( substr( $s, $pos, 1 ) eq '{' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1292} ) && 0 ) ) + ## + + && + + ## + ## pos: 2498 2520 + ( ( $pad{I1293} = $pos or 1 ) && + ## + ## pos: 2498 2512 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1293} ) && 0 ) ) + ## + + && + + ## + ## pos: 2520 2527 + ( ( $pad{I1294} = $pos or 1 ) && + + ## + ## pos: 2520 2522 + ( ( substr( $s, $pos, 1 ) eq '}' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1294} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && ## + ## pos: 2528 2556 + ( + + ## + ## pos: 2528 2534 + ( ( $pad{I1295} = $pos or 1 ) && + + ## + ## pos: 2530 2532 + ( ( substr( $s, $pos, 1 ) eq '<' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1295} ) && 0 ) ) + ## + + && + + ## + ## pos: 2534 2549 + ( ( $pad{I1296} = $pos or 1 ) && + ## + ## pos: 2534 2547 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->metasyntax( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1296} ) && 0 ) ) + ## + + && + + ## + ## pos: 2549 2556 + ( ( $pad{I1297} = $pos or 1 ) && + + ## + ## pos: 2549 2551 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1297} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1283} ) or 1 ) + && + ## + ## pos: 2557 2573 + ( ( $pad{I1298} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\>]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1298} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1282} ) && 0 ) )) {}; $bool = 1 } + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token char_range +*char_range = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 2602 2653 + ( + ( ( $pad{I1299} = $pos or 1 ) && + ## + ## pos: 2603 2650 + ( + ( $pad{I1300} = $pos or 1 ) + && ( + ## + ## pos: 2609 2633 + ( + + ## + ## pos: 2609 2614 + ( ( $pad{I1301} = $pos or 1 ) && + + ## + ## pos: 2611 2613 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1301} ) && 0 ) ) + ## + + && + + ## + ## pos: 2614 2633 + ( ( $pad{I1302} = $pos or 1 ) && + ## + ## pos: 2614 2628 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1302} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1300} ) or 1 ) + && + ## + ## pos: 2634 2650 + ( ( $pad{I1303} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\]]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1303} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1299} ) && 0 ) ) + && do { while ( + ( ( $pad{I1299} = $pos or 1 ) && + ## + ## pos: 2603 2650 + ( + ( $pad{I1300} = $pos or 1 ) + && ( + ## + ## pos: 2609 2633 + ( + + ## + ## pos: 2609 2614 + ( ( $pad{I1301} = $pos or 1 ) && + + ## + ## pos: 2611 2613 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1301} ) && 0 ) ) + ## + + && + + ## + ## pos: 2614 2633 + ( ( $pad{I1302} = $pos or 1 ) && + ## + ## pos: 2614 2628 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1302} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1300} ) or 1 ) + && + ## + ## pos: 2634 2650 + ( ( $pad{I1303} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\]]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1303} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1299} ) && 0 ) )) {}; $bool = 1 } + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token char_class +*char_class = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 2679 2721 + ( + ( $pad{I1304} = $pos or 1 ) + && ( + ## + ## pos: 2680 2696 + ( + ( ( $pad{I1305} = $pos or 1 ) && + ## + ## pos: 2682 2690 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alpha( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1305} ) && 0 ) ) + && do { while ( + ( ( $pad{I1305} = $pos or 1 ) && + ## + ## pos: 2682 2690 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alpha( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1305} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1304} ) or 1 ) + && ## + ## pos: 2697 2721 + ( + + ## + ## pos: 2697 2703 + ( ( $pad{I1306} = $pos or 1 ) && + + ## + ## pos: 2699 2701 + ( ( substr( $s, $pos, 1 ) eq '[' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1306} ) && 0 ) ) + ## + + && + + ## + ## pos: 2703 2718 + ( ( $pad{I1307} = $pos or 1 ) && + ## + ## pos: 2703 2716 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_range( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1307} ) && 0 ) ) + ## + + && + + ## + ## pos: 2718 2721 + ( ( $pad{I1308} = $pos or 1 ) && + + ## + ## pos: 2718 2720 + ( ( substr( $s, $pos, 1 ) eq ']' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1308} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token string_code +*string_code = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 2771 3055 + ( + ( ( $pad{I1309} = $pos or 1 ) && + ## + ## pos: 2772 3052 + ( + ( $pad{I1310} = $pos or 1 ) + && ( + ## + ## pos: 2778 2802 + ( + + ## + ## pos: 2778 2783 + ( ( $pad{I1311} = $pos or 1 ) && + + ## + ## pos: 2780 2782 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1311} ) && 0 ) ) + ## + + && + + ## + ## pos: 2783 2802 + ( ( $pad{I1312} = $pos or 1 ) && + ## + ## pos: 2783 2797 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1312} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2803 2831 + ( + + ## + ## pos: 2803 2809 + ( ( $pad{I1313} = $pos or 1 ) && + + ## + ## pos: 2805 2807 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1313} ) && 0 ) ) + ## + + && + + ## + ## pos: 2809 2824 + ( ( $pad{I1314} = $pos or 1 ) && + ## + ## pos: 2809 2819 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->literal( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1314} ) && 0 ) ) + ## + + && + + ## + ## pos: 2824 2831 + ( ( $pad{I1315} = $pos or 1 ) && + + ## + ## pos: 2824 2826 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1315} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2832 2864 + ( + + ## + ## pos: 2832 2838 + ( ( $pad{I1316} = $pos or 1 ) && + + ## + ## pos: 2834 2836 + ( ( substr( $s, $pos, 1 ) eq '"' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1316} ) && 0 ) ) + ## + + && + + ## + ## pos: 2838 2857 + ( ( $pad{I1317} = $pos or 1 ) && + ## + ## pos: 2838 2854 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->double_quoted( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1317} ) && 0 ) ) + ## + + && + + ## + ## pos: 2857 2864 + ( ( $pad{I1318} = $pos or 1 ) && + + ## + ## pos: 2857 2859 + ( ( substr( $s, $pos, 1 ) eq '"' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1318} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2865 2903 + ( + + ## + ## pos: 2865 2871 + ( ( $pad{I1319} = $pos or 1 ) && + + ## + ## pos: 2867 2869 + ( ( substr( $s, $pos, 1 ) eq '{' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1319} ) && 0 ) ) + ## + + && + + ## + ## pos: 2871 2896 + ( ( $pad{I1320} = $pos or 1 ) && + ## + ## pos: 2872 2893 + ( + ( $pad{I1321} = $pos or 1 ) + && ( + + ## + ## pos: 2872 2888 + ( ( $pad{I1322} = $pos or 1 ) && + ## + ## pos: 2873 2887 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1322} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1321} ) or 1 ) + && + ## + ## pos: 2889 2893 + ( ( $pad{I1323} = $pos or 1 ) && + 1 # null constant + || ( ( $pos = $pad{I1323} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1320} ) && 0 ) ) + ## + + && + + ## + ## pos: 2896 2903 + ( ( $pad{I1324} = $pos or 1 ) && + + ## + ## pos: 2896 2898 + ( ( substr( $s, $pos, 1 ) eq '}' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1324} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2904 2942 + ( + + ## + ## pos: 2904 2910 + ( ( $pad{I1325} = $pos or 1 ) && + + ## + ## pos: 2906 2908 + ( ( substr( $s, $pos, 1 ) eq '(' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1325} ) && 0 ) ) + ## + + && + + ## + ## pos: 2910 2935 + ( ( $pad{I1326} = $pos or 1 ) && + ## + ## pos: 2911 2932 + ( + ( $pad{I1327} = $pos or 1 ) + && ( + + ## + ## pos: 2911 2927 + ( ( $pad{I1328} = $pos or 1 ) && + ## + ## pos: 2912 2926 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1328} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1327} ) or 1 ) + && + ## + ## pos: 2928 2932 + ( ( $pad{I1329} = $pos or 1 ) && + 1 # null constant + || ( ( $pos = $pad{I1329} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1326} ) && 0 ) ) + ## + + && + + ## + ## pos: 2935 2942 + ( ( $pad{I1330} = $pos or 1 ) && + + ## + ## pos: 2935 2937 + ( ( substr( $s, $pos, 1 ) eq ')' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1330} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2943 2981 + ( + + ## + ## pos: 2943 2949 + ( ( $pad{I1331} = $pos or 1 ) && + + ## + ## pos: 2945 2947 + ( ( substr( $s, $pos, 1 ) eq '<' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1331} ) && 0 ) ) + ## + + && + + ## + ## pos: 2949 2974 + ( ( $pad{I1332} = $pos or 1 ) && + ## + ## pos: 2950 2971 + ( + ( $pad{I1333} = $pos or 1 ) + && ( + + ## + ## pos: 2950 2966 + ( ( $pad{I1334} = $pos or 1 ) && + ## + ## pos: 2951 2965 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1334} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1333} ) or 1 ) + && + ## + ## pos: 2967 2971 + ( ( $pad{I1335} = $pos or 1 ) && + 1 # null constant + || ( ( $pos = $pad{I1335} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1332} ) && 0 ) ) + ## + + && + + ## + ## pos: 2974 2981 + ( ( $pad{I1336} = $pos or 1 ) && + + ## + ## pos: 2974 2976 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1336} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2982 3016 + ( + + ## + ## pos: 2982 3009 + ( ( $pad{I1337} = $pos or 1 ) && + ## + ## pos: 2985 3007 + ( + ( $pad{I1338} = $pos or 1 ) + && ( + + ## + ## pos: 2985 2992 + ( ( $pad{I1339} = $pos or 1 ) && + ## + ## pos: 2986 2991 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1339} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1338} ) or 1 ) + && + ## + ## pos: 2993 2997 + ( ( $pad{I1340} = $pos or 1 ) && + + ## + ## pos: 2994 2996 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1340} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1338} ) or 1 ) + && + ## + ## pos: 2998 3002 + ( ( $pad{I1341} = $pos or 1 ) && + + ## + ## pos: 2999 3001 + ( ( substr( $s, $pos, 1 ) eq '=' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1341} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1338} ) or 1 ) + && + ## + ## pos: 3003 3007 + ( ( $pad{I1342} = $pos or 1 ) && + + ## + ## pos: 3004 3006 + ( ( substr( $s, $pos, 1 ) eq '-' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1342} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1337} ) && 0 ) ) + ## + + && + + ## + ## pos: 3009 3016 + ( ( $pad{I1343} = $pos or 1 ) && + + ## + ## pos: 3009 3011 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1343} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && + ## + ## pos: 3017 3029 + ( ( $pad{I1344} = $pos or 1 ) && + ## + ## pos: 3019 3024 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1344} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && + ## + ## pos: 3030 3052 + ( ( $pad{I1345} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\}\)\>]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1345} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1309} ) && 0 ) ) + && do { while ( + ( ( $pad{I1309} = $pos or 1 ) && + ## + ## pos: 2772 3052 + ( + ( $pad{I1310} = $pos or 1 ) + && ( + ## + ## pos: 2778 2802 + ( + + ## + ## pos: 2778 2783 + ( ( $pad{I1311} = $pos or 1 ) && + + ## + ## pos: 2780 2782 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1311} ) && 0 ) ) + ## + + && + + ## + ## pos: 2783 2802 + ( ( $pad{I1312} = $pos or 1 ) && + ## + ## pos: 2783 2797 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1312} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2803 2831 + ( + + ## + ## pos: 2803 2809 + ( ( $pad{I1313} = $pos or 1 ) && + + ## + ## pos: 2805 2807 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1313} ) && 0 ) ) + ## + + && + + ## + ## pos: 2809 2824 + ( ( $pad{I1314} = $pos or 1 ) && + ## + ## pos: 2809 2819 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->literal( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1314} ) && 0 ) ) + ## + + && + + ## + ## pos: 2824 2831 + ( ( $pad{I1315} = $pos or 1 ) && + + ## + ## pos: 2824 2826 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1315} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2832 2864 + ( + + ## + ## pos: 2832 2838 + ( ( $pad{I1316} = $pos or 1 ) && + + ## + ## pos: 2834 2836 + ( ( substr( $s, $pos, 1 ) eq '"' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1316} ) && 0 ) ) + ## + + && + + ## + ## pos: 2838 2857 + ( ( $pad{I1317} = $pos or 1 ) && + ## + ## pos: 2838 2854 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->double_quoted( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1317} ) && 0 ) ) + ## + + && + + ## + ## pos: 2857 2864 + ( ( $pad{I1318} = $pos or 1 ) && + + ## + ## pos: 2857 2859 + ( ( substr( $s, $pos, 1 ) eq '"' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1318} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2865 2903 + ( + + ## + ## pos: 2865 2871 + ( ( $pad{I1319} = $pos or 1 ) && + + ## + ## pos: 2867 2869 + ( ( substr( $s, $pos, 1 ) eq '{' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1319} ) && 0 ) ) + ## + + && + + ## + ## pos: 2871 2896 + ( ( $pad{I1320} = $pos or 1 ) && + ## + ## pos: 2872 2893 + ( + ( $pad{I1321} = $pos or 1 ) + && ( + + ## + ## pos: 2872 2888 + ( ( $pad{I1322} = $pos or 1 ) && + ## + ## pos: 2873 2887 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1322} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1321} ) or 1 ) + && + ## + ## pos: 2889 2893 + ( ( $pad{I1323} = $pos or 1 ) && + 1 # null constant + || ( ( $pos = $pad{I1323} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1320} ) && 0 ) ) + ## + + && + + ## + ## pos: 2896 2903 + ( ( $pad{I1324} = $pos or 1 ) && + + ## + ## pos: 2896 2898 + ( ( substr( $s, $pos, 1 ) eq '}' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1324} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2904 2942 + ( + + ## + ## pos: 2904 2910 + ( ( $pad{I1325} = $pos or 1 ) && + + ## + ## pos: 2906 2908 + ( ( substr( $s, $pos, 1 ) eq '(' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1325} ) && 0 ) ) + ## + + && + + ## + ## pos: 2910 2935 + ( ( $pad{I1326} = $pos or 1 ) && + ## + ## pos: 2911 2932 + ( + ( $pad{I1327} = $pos or 1 ) + && ( + + ## + ## pos: 2911 2927 + ( ( $pad{I1328} = $pos or 1 ) && + ## + ## pos: 2912 2926 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1328} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1327} ) or 1 ) + && + ## + ## pos: 2928 2932 + ( ( $pad{I1329} = $pos or 1 ) && + 1 # null constant + || ( ( $pos = $pad{I1329} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1326} ) && 0 ) ) + ## + + && + + ## + ## pos: 2935 2942 + ( ( $pad{I1330} = $pos or 1 ) && + + ## + ## pos: 2935 2937 + ( ( substr( $s, $pos, 1 ) eq ')' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1330} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2943 2981 + ( + + ## + ## pos: 2943 2949 + ( ( $pad{I1331} = $pos or 1 ) && + + ## + ## pos: 2945 2947 + ( ( substr( $s, $pos, 1 ) eq '<' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1331} ) && 0 ) ) + ## + + && + + ## + ## pos: 2949 2974 + ( ( $pad{I1332} = $pos or 1 ) && + ## + ## pos: 2950 2971 + ( + ( $pad{I1333} = $pos or 1 ) + && ( + + ## + ## pos: 2950 2966 + ( ( $pad{I1334} = $pos or 1 ) && + ## + ## pos: 2951 2965 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1334} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1333} ) or 1 ) + && + ## + ## pos: 2967 2971 + ( ( $pad{I1335} = $pos or 1 ) && + 1 # null constant + || ( ( $pos = $pad{I1335} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1332} ) && 0 ) ) + ## + + && + + ## + ## pos: 2974 2981 + ( ( $pad{I1336} = $pos or 1 ) && + + ## + ## pos: 2974 2976 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1336} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && ## + ## pos: 2982 3016 + ( + + ## + ## pos: 2982 3009 + ( ( $pad{I1337} = $pos or 1 ) && + ## + ## pos: 2985 3007 + ( + ( $pad{I1338} = $pos or 1 ) + && ( + + ## + ## pos: 2985 2992 + ( ( $pad{I1339} = $pos or 1 ) && + ## + ## pos: 2986 2991 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1339} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1338} ) or 1 ) + && + ## + ## pos: 2993 2997 + ( ( $pad{I1340} = $pos or 1 ) && + + ## + ## pos: 2994 2996 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1340} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1338} ) or 1 ) + && + ## + ## pos: 2998 3002 + ( ( $pad{I1341} = $pos or 1 ) && + + ## + ## pos: 2999 3001 + ( ( substr( $s, $pos, 1 ) eq '=' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1341} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1338} ) or 1 ) + && + ## + ## pos: 3003 3007 + ( ( $pad{I1342} = $pos or 1 ) && + + ## + ## pos: 3004 3006 + ( ( substr( $s, $pos, 1 ) eq '-' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1342} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1337} ) && 0 ) ) + ## + + && + + ## + ## pos: 3009 3016 + ( ( $pad{I1343} = $pos or 1 ) && + + ## + ## pos: 3009 3011 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1343} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && + ## + ## pos: 3017 3029 + ( ( $pad{I1344} = $pos or 1 ) && + ## + ## pos: 3019 3024 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1344} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1310} ) or 1 ) + && + ## + ## pos: 3030 3052 + ( ( $pad{I1345} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\}\)\>]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1345} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1309} ) && 0 ) )) {}; $bool = 1 } + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token parsed_code +*parsed_code = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 3141 3187 + ( + + ## + ## pos: 3141 3160 + ( ( $pad{I1346} = $pos or 1 ) && + ## + ## pos: 3141 3155 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->string_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1346} ) && 0 ) ) + ## + + && + + ## + ## pos: 3160 3187 + ( ( $pad{I1347} = $pos or 1 ) && + ## + ## pos: 3160 3186 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return '{' . $_[0] . '}'; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1347} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token named_capture_body +*named_capture_body = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 3221 3712 + ( + ( $pad{I1348} = $pos or 1 ) + && ( + ## + ## pos: 3222 3354 + ( + + ## + ## pos: 3222 3227 + ( ( $pad{I1349} = $pos or 1 ) && + + ## + ## pos: 3223 3225 + ( ( substr( $s, $pos, 1 ) eq '(' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1349} ) && 0 ) ) + ## + + && + + ## + ## pos: 3227 3241 + ( ( $pad{I1350} = $pos or 1 ) && + ## + ## pos: 3227 3233 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1350} ) && 0 ) ) + ## + + && + + ## + ## pos: 3241 3245 + ( ( $pad{I1351} = $pos or 1 ) && + + ## + ## pos: 3241 3243 + ( ( substr( $s, $pos, 1 ) eq ')' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1351} ) && 0 ) ) + ## + + && + + ## + ## pos: 3245 3354 + ( ( $pad{I1352} = $pos or 1 ) && + ## + ## pos: 3245 3349 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { capturing_group => ${ $_[0]->{qw(rule)} }, + _pos => [ $_[0]->from, $_[0]->to ], }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1352} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1348} ) or 1 ) + && ## + ## pos: 3355 3402 + ( + + ## + ## pos: 3355 3360 + ( ( $pad{I1353} = $pos or 1 ) && + + ## + ## pos: 3356 3358 + ( ( substr( $s, $pos, 1 ) eq '[' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1353} ) && 0 ) ) + ## + + && + + ## + ## pos: 3360 3374 + ( ( $pad{I1354} = $pos or 1 ) && + ## + ## pos: 3360 3366 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1354} ) && 0 ) ) + ## + + && + + ## + ## pos: 3374 3378 + ( ( $pad{I1355} = $pos or 1 ) && + + ## + ## pos: 3374 3376 + ( ( substr( $s, $pos, 1 ) eq ']' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1355} ) && 0 ) ) + ## + + && + + ## + ## pos: 3378 3402 + ( ( $pad{I1356} = $pos or 1 ) && + ## + ## pos: 3378 3397 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return ${ $_[0]->{qw(rule)} } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1356} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1348} ) or 1 ) + && ## + ## pos: 3403 3464 + ( + + ## + ## pos: 3403 3408 + ( ( $pad{I1357} = $pos or 1 ) && + + ## + ## pos: 3404 3406 + ( ( substr( $s, $pos, 1 ) eq '<' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1357} ) && 0 ) ) + ## + + && + + ## + ## pos: 3408 3428 + ( ( $pad{I1358} = $pos or 1 ) && + ## + ## pos: 3408 3426 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->parse_metasyntax( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'parse_metasyntax'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1358} ) && 0 ) ) + ## + + && + + ## + ## pos: 3428 3464 + ( ( $pad{I1359} = $pos or 1 ) && + ## + ## pos: 3428 3459 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return ${ $_[0]->{qw(parse_metasyntax)} } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1359} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1348} ) or 1 ) + && ## + ## pos: 3465 3678 + ( + + ## + ## pos: 3465 3470 + ( ( $pad{I1360} = $pos or 1 ) && + + ## + ## pos: 3466 3468 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1360} ) && 0 ) ) + ## + + && + + ## + ## pos: 3470 3484 + ( ( $pad{I1361} = $pos or 1 ) && + ## + ## pos: 3470 3480 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->literal( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1361} ) && 0 ) ) + ## + + && + + ## + ## pos: 3484 3495 + ( ( $pad{I1362} = $pos or 1 ) && + + ## + ## pos: 3484 3486 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1362} ) && 0 ) ) + ## + + && + + ## + ## pos: 3495 3678 + ( ( $pad{I1363} = $pos or 1 ) && + ## + ## pos: 3495 3673 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { metasyntax => { + metasyntax => "${$_[0]}", + }, + _pos => [ $_[0]->from, $_[0]->to ], + }; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1363} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1348} ) or 1 ) + && + ## + ## pos: 3679 3712 + ( ( $pad{I1364} = $pos or 1 ) && + ## + ## pos: 3680 3711 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + sub { die "invalid alias syntax"; }->( $m ); + 1; + } + ## + || ( ( $pos = $pad{I1364} ) && 0 ) ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token parse_metasyntax +*parse_metasyntax = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 3748 6621 + ( + + ## + ## pos: 3748 3792 + ( ( $pad{I1365} = $pos or 1 ) && + ## + ## pos: 3748 3787 + do{ + my $from = $pos; + my $bool = ## + ## pos: 3764 3786 + ( + ( $pad{I1366} = $pos or 1 ) + && ( + + ## + ## pos: 3764 3769 + ( ( $pad{I1367} = $pos or 1 ) && + + ## + ## pos: 3765 3768 + ( ( substr( $s, $pos, 1 ) eq '!' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1367} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1366} ) or 1 ) + && + ## + ## pos: 3770 3775 + ( ( $pad{I1368} = $pos or 1 ) && + + ## + ## pos: 3771 3774 + ( ( substr( $s, $pos, 1 ) eq '?' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1368} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1366} ) or 1 ) + && + ## + ## pos: 3776 3781 + ( ( $pad{I1369} = $pos or 1 ) && + + ## + ## pos: 3777 3780 + ( ( substr( $s, $pos, 1 ) eq '.' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1369} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1366} ) or 1 ) + && + ## + ## pos: 3782 3786 + ( ( $pad{I1370} = $pos or 1 ) && + 1 # null constant + || ( ( $pos = $pad{I1370} ) && 0 ) ) + ## + + ) + ) + ## + ; + my $match = Pugs::Runtime::Match->new( + { str => \$s, from => \$from, match => [], named => {}, bool => \1, to => \(0+$pos), capture => undef } + ); $named{'modifier'} = $match; + $bool + } + ## + || ( ( $pos = $pad{I1365} ) && 0 ) ) + ## + + && + + ## + ## pos: 3792 6621 + ( ( $pad{I1371} = $pos or 1 ) && + ## + ## pos: 3793 6619 + ( + ( $pad{I1372} = $pos or 1 ) + && ( + ## + ## pos: 3793 4011 + ( + + ## + ## pos: 3793 3807 + ( ( $pad{I1373} = $pos or 1 ) && + + ## + ## pos: 3802 3805 + ( ( substr( $s, $pos, 1 ) eq '{' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1373} ) && 0 ) ) + ## + + && + + ## + ## pos: 3807 3822 + ( ( $pad{I1374} = $pos or 1 ) && + ## + ## pos: 3807 3820 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->parsed_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'parsed_code'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1374} ) && 0 ) ) + ## + + && + + ## + ## pos: 3822 3835 + ( ( $pad{I1375} = $pos or 1 ) && + + ## + ## pos: 3822 3826 + ( ( substr( $s, $pos, 2 ) eq '}>' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1375} ) && 0 ) ) + ## + + && + + ## + ## pos: 3835 4011 + ( ( $pad{I1376} = $pos or 1 ) && + ## + ## pos: 3835 4006 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { closure => { + closure => ${ $_[0]->{qw(parsed_code)} }, + modifier => ${ $_[0]->{qw(modifier)} }, + }, + _pos => [ $_[0]->from - 1, $_[0]->to ], + } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1376} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1372} ) or 1 ) + && ## + ## pos: 4012 4505 + ( + + ## + ## pos: 4012 4042 + ( ( $pad{I1377} = $pos or 1 ) && + ## + ## pos: 4021 4033 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_class( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_class'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1377} ) && 0 ) ) + ## + + && + ## + ## pos: 4042 4075 + ( + ( ( $pad{I1378} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 4043 4064 + ( + + ## + ## pos: 4043 4051 + ( ( $pad{I1379} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[+-]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1379} ) && 0 ) ) + ## + + && + + ## + ## pos: 4051 4064 + ( ( $pad{I1380} = $pos or 1 ) && + ## + ## pos: 4051 4063 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_class( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_class'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1380} ) && 0 ) ) + ## + + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + if ( $bool ) { + push @{ $match[ 0 ] }, Pugs::Runtime::Match->new( $hash ); + } + $bool; + } + ## + || ( ( $pos = $pad{I1378} ) && 0 ) ) + && do { while ( + ( ( $pad{I1378} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 4043 4064 + ( + + ## + ## pos: 4043 4051 + ( ( $pad{I1379} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[+-]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1379} ) && 0 ) ) + ## + + && + + ## + ## pos: 4051 4064 + ( ( $pad{I1380} = $pos or 1 ) && + ## + ## pos: 4051 4063 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_class( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_class'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1380} ) && 0 ) ) + ## + + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + if ( $bool ) { + push @{ $match[ 0 ] }, Pugs::Runtime::Match->new( $hash ); + } + $bool; + } + ## + || ( ( $pos = $pad{I1378} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 4075 4086 + ( ( $pad{I1381} = $pos or 1 ) && + + ## + ## pos: 4075 4077 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1381} ) && 0 ) ) + ## + + && + + ## + ## pos: 4086 4505 + ( ( $pad{I1382} = $pos or 1 ) && + ## + ## pos: 4086 4500 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + if ( ${ $_[0]->{qw(modifier)} } eq '!' ) { + return { + negate => { + char_class => [ + '+' . $_[0]->{qw(char_class)}, + @{$_[0]->[0]}, # TODO - stringify + ] } } + } + return { + char_class => [ + '+' . $_[0]->{qw(char_class)}, + @{$_[0]->[0]}, # TODO - stringify + ] } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1382} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1372} ) or 1 ) + && ## + ## pos: 4506 6394 + ( + + ## + ## pos: 4506 4531 + ( ( $pad{I1383} = $pos or 1 ) && + ## + ## pos: 4515 4522 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ident( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'ident'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1383} ) && 0 ) ) + ## + + && + + ## + ## pos: 4531 6394 + ( ( $pad{I1384} = $pos or 1 ) && + ## + ## pos: 4532 6388 + ( + ( $pad{I1385} = $pos or 1 ) + && ( + ## + ## pos: 4532 5149 + ( + + ## + ## pos: 4532 4549 + ( ( $pad{I1386} = $pos or 1 ) && + ## + ## pos: 4543 4548 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1386} ) && 0 ) ) + ## + + && + + ## + ## pos: 4549 4556 + ( ( $pad{I1387} = $pos or 1 ) && + ## + ## pos: 4549 4555 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1387} ) && 0 ) ) + ## + + && + + ## + ## pos: 4556 4569 + ( ( $pad{I1388} = $pos or 1 ) && + + ## + ## pos: 4556 4558 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1388} ) && 0 ) ) + ## + + && + + ## + ## pos: 4569 5149 + ( ( $pad{I1389} = $pos or 1 ) && + ## + ## pos: 4569 5140 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + if ( ${ $_[0]->{qw(ident)} } eq 'before' + || ${ $_[0]->{qw(ident)} } eq 'after' + ) { + return { ${ $_[0]->{qw(ident)} } => { + rule => ${ $_[0]->{qw(rule)} }, modifier => ${ $_[0]->{qw(modifier)} }, + }, _pos => [ $_[0]->from - 1, $_[0]->to ], } + } + return { metasyntax => { + metasyntax => ${ $_[0]->{qw(ident)} }, + rule => ${ $_[0]->{qw(rule)} }, + modifier => ${ $_[0]->{qw(modifier)} }, + }, + _pos => [ $_[0]->from - 1, $_[0]->to ], + } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1389} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1385} ) or 1 ) + && ## + ## pos: 5150 6129 + ( + + ## + ## pos: 5150 5165 + ( ( $pad{I1390} = $pos or 1 ) && + + ## + ## pos: 5161 5164 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1390} ) && 0 ) ) + ## + + && + ## + ## pos: 5165 5182 + ( + ( ( $pad{I1391} = $pos or 1 ) && + ## + ## pos: 5165 5170 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1391} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 5182 5352 + ( ( $pad{I1392} = $pos or 1 ) && + ## + ## pos: 5182 5341 + do{ + my $from = $pos; + my $bool = ## + ## pos: 5193 5340 + do { while ( + ( ( $pad{I1393} = $pos or 1 ) && + ## + ## pos: 5207 5327 + ( + ( $pad{I1394} = $pos or 1 ) + && ( + ## + ## pos: 5221 5253 + ( + + ## + ## pos: 5221 5226 + ( ( $pad{I1395} = $pos or 1 ) && + + ## + ## pos: 5223 5225 + ( ( substr( $s, $pos, 1 ) eq '\\' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1395} ) && 0 ) ) + ## + + && + + ## + ## pos: 5226 5253 + ( ( $pad{I1396} = $pos or 1 ) && + ## + ## pos: 5226 5240 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'special_char'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1396} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1394} ) or 1 ) + && + ## + ## pos: 5254 5302 + ( ( $pad{I1397} = $pos or 1 ) && + ## + ## pos: 5256 5289 + do{ + my $match = + ## + ## pos: 5256 5289 + do { + our $I1398; + our $I1398_sizes; + unless ( $I1398 ) { + my $hash = \%Pugs::Grammar::Rule::variables; + my %sizes = map { length($_) => 1 } keys %$hash; + $I1398_sizes = [ sort { $b <=> $a } keys %sizes ]; + $I1398 = $hash; + } + my $match = 0; + my $key; + for ( @$I1398_sizes ) { + $key = ( $pos <= length( $s ) + ? substr( $s, $pos, $_ ) + : '' ); + if ( exists $I1398->{$key} ) { + #$named{KEY} = $key; + #$::_V6_MATCH_ = $m; + #print "m: ", Dumper( $::_V6_MATCH_->data ) + # if ( $key eq 'until' ); + $match = Pugs::Runtime::Regex::preprocess_hash( $I1398, $key )->( $s, $grammar, { p => ( $pos + $_ ), positionals => [ ], args => { KEY => $key } }, undef ); + last if $match; + } + } + if ( $match ) { + $pos = $match->to; + #print "match: $key at $pos = ", Dumper( $match->data ); + $bool = 1; + }; # else { $bool = 0 } + $match; + } + ## + ; + if ( $match ) { push @{$named{'Pugs::Grammar::Rule::variables'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1397} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1394} ) or 1 ) + && + ## + ## pos: 5303 5327 + ( ( $pad{I1399} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\>]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1399} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1393} ) && 0 ) )) {}; $bool = 1 } + ## + ; + my $match = Pugs::Runtime::Match->new( + { str => \$s, from => \$from, match => [], named => {}, bool => \1, to => \(0+$pos), capture => undef } + ); $named{'str'} = $match; + $bool + } + ## + || ( ( $pos = $pad{I1392} ) && 0 ) ) + ## + + && + + ## + ## pos: 5352 5365 + ( ( $pad{I1400} = $pos or 1 ) && + + ## + ## pos: 5352 5354 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1400} ) && 0 ) ) + ## + + && + + ## + ## pos: 5365 6129 + ( ( $pad{I1401} = $pos or 1 ) && + ## + ## pos: 5365 6120 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + if ( ${ $_[0]->{qw(ident)} } eq 'before' + || ${ $_[0]->{qw(ident)} } eq 'after' + ) { + return { ${ $_[0]->{qw(ident)} } => { + rule => { metasyntax => { + metasyntax => '\'' . ${ $_[0]->{qw(str)} } . '\'', + }, + _pos => [ $_[0]->{qw(str)}->from, $_[0]->{qw(str)}->to ], }, + modifier => ${ $_[0]->{qw(modifier)} }, + _pos => [ $_[0]->from - 1, $_[0]->to ], + } } + } + return { metasyntax => { + metasyntax => ${ $_[0]->{qw(ident)} }, + string => ${ $_[0]->{qw(str)} }, + modifier => ${ $_[0]->{qw(modifier)} }, + }, + _pos => [ $_[0]->from - 1, $_[0]->to ], + } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1401} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1385} ) or 1 ) + && ## + ## pos: 6130 6388 + ( + + ## + ## pos: 6130 6145 + ( ( $pad{I1402} = $pos or 1 ) && + + ## + ## pos: 6141 6143 + ( ( substr( $s, $pos, 1 ) eq '(' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1402} ) && 0 ) ) + ## + + && + + ## + ## pos: 6145 6160 + ( ( $pad{I1403} = $pos or 1 ) && + ## + ## pos: 6145 6158 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->parsed_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'parsed_code'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1403} ) && 0 ) ) + ## + + && + + ## + ## pos: 6160 6163 + ( ( $pad{I1404} = $pos or 1 ) && + + ## + ## pos: 6160 6162 + ( ( substr( $s, $pos, 1 ) eq ')' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1404} ) && 0 ) ) + ## + + && + + ## + ## pos: 6163 6176 + ( ( $pad{I1405} = $pos or 1 ) && + + ## + ## pos: 6163 6165 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1405} ) && 0 ) ) + ## + + && + + ## + ## pos: 6176 6388 + ( ( $pad{I1406} = $pos or 1 ) && + ## + ## pos: 6176 6379 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { call => { + method => ${ $_[0]->{qw(ident)} }, + params => ${ $_[0]->{qw(parsed_code)} }, + modifier => ${ $_[0]->{qw(modifier)} }, + }, + _pos => [$_[0]->from - 1, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1406} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1384} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1372} ) or 1 ) + && ## + ## pos: 6395 6619 + ( + + ## + ## pos: 6395 6418 + ( ( $pad{I1407} = $pos or 1 ) && + ## + ## pos: 6404 6416 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->metasyntax( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'metasyntax'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1407} ) && 0 ) ) + ## + + && + + ## + ## pos: 6418 6429 + ( ( $pad{I1408} = $pos or 1 ) && + + ## + ## pos: 6418 6420 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1408} ) && 0 ) ) + ## + + && + + ## + ## pos: 6429 6619 + ( ( $pad{I1409} = $pos or 1 ) && + ## + ## pos: 6429 6614 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { metasyntax => { + metasyntax => "${ $_[0]->{qw(metasyntax)} }", + modifier => ${ $_[0]->{qw(modifier)} }, + }, + _pos => [ $_[0]->from - 1, $_[0]->to ], + } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1409} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1371} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token var1 +*var1 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 6731 6833 + ( + + ## + ## pos: 6731 6739 + ( ( $pad{I1410} = $pos or 1 ) && + ## + ## pos: 6731 6738 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ident( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'ident'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1410} ) && 0 ) ) + ## + + && + + ## + ## pos: 6739 6750 + ( ( $pad{I1411} = $pos or 1 ) && + + ## + ## pos: 6739 6741 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1411} ) && 0 ) ) + ## + + && + + ## + ## pos: 6750 6833 + ( ( $pad{I1412} = $pos or 1 ) && + ## + ## pos: 6750 6832 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { match_variable => '$' . $_[0]->{ident}, _pos => [$_[0]->from - 2, $_[0]->to], }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1412} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $variables{'$<'} = sub { var1($_[1], $_[0], $_[2], $_[3]) }; + +# token var2 +*var2 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 6925 7149 + ( + ( $pad{I1413} = $pos or 1 ) + && ( + ## + ## pos: 6925 7023 + ( + ## + ## pos: 6925 6943 + ( + ( ( $pad{I1414} = $pos or 1 ) && + ## + ## pos: 6925 6933 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->digit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1414} ) && 0 ) ) + && do { while ( + ( ( $pad{I1414} = $pos or 1 ) && + ## + ## pos: 6925 6933 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->digit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1414} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 6943 7023 + ( ( $pad{I1415} = $pos or 1 ) && + ## + ## pos: 6943 7018 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { match_variable => '$' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to], }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1415} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1413} ) or 1 ) + && ## + ## pos: 7024 7149 + ( + ## + ## pos: 7024 7045 + ( + ( ( $pad{I1416} = $pos or 1 ) && + + ## + ## pos: 7033 7035 + ( ( substr( $s, $pos, 1 ) eq '^' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1416} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 7045 7079 + ( + ( ( $pad{I1417} = $pos or 1 ) && + ## + ## pos: 7046 7068 + ( + ( $pad{I1418} = $pos or 1 ) + && ( + + ## + ## pos: 7046 7056 + ( ( $pad{I1419} = $pos or 1 ) && + ## + ## pos: 7047 7055 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1419} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1418} ) or 1 ) + && + ## + ## pos: 7057 7060 + ( ( $pad{I1420} = $pos or 1 ) && + + ## + ## pos: 7058 7059 + ( ( substr( $s, $pos, 1 ) eq '_' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1420} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1418} ) or 1 ) + && ## + ## pos: 7061 7068 + ( + + ## + ## pos: 7061 7065 + ( ( $pad{I1421} = $pos or 1 ) && + + ## + ## pos: 7062 7064 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1421} ) && 0 ) ) + ## + + && + + ## + ## pos: 7065 7068 + ( ( $pad{I1422} = $pos or 1 ) && + + ## + ## pos: 7065 7067 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1422} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1417} ) && 0 ) ) + && do { while ( + ( ( $pad{I1417} = $pos or 1 ) && + ## + ## pos: 7046 7068 + ( + ( $pad{I1418} = $pos or 1 ) + && ( + + ## + ## pos: 7046 7056 + ( ( $pad{I1419} = $pos or 1 ) && + ## + ## pos: 7047 7055 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1419} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1418} ) or 1 ) + && + ## + ## pos: 7057 7060 + ( ( $pad{I1420} = $pos or 1 ) && + + ## + ## pos: 7058 7059 + ( ( substr( $s, $pos, 1 ) eq '_' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1420} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1418} ) or 1 ) + && ## + ## pos: 7061 7068 + ( + + ## + ## pos: 7061 7065 + ( ( $pad{I1421} = $pos or 1 ) && + + ## + ## pos: 7062 7064 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1421} ) && 0 ) ) + ## + + && + + ## + ## pos: 7065 7068 + ( ( $pad{I1422} = $pos or 1 ) && + + ## + ## pos: 7065 7067 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1422} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1417} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 7079 7149 + ( ( $pad{I1423} = $pos or 1 ) && + ## + ## pos: 7079 7148 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { variable => '$' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to], }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1423} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $variables{'$'} = sub { var2($_[1], $_[0], $_[2], $_[3]) }; + +# token var3 +*var3 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 7240 7462 + ( + ( $pad{I1424} = $pos or 1 ) + && ( + ## + ## pos: 7240 7337 + ( + ## + ## pos: 7240 7258 + ( + ( ( $pad{I1425} = $pos or 1 ) && + ## + ## pos: 7240 7248 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->digit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1425} ) && 0 ) ) + && do { while ( + ( ( $pad{I1425} = $pos or 1 ) && + ## + ## pos: 7240 7248 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->digit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1425} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 7258 7337 + ( ( $pad{I1426} = $pos or 1 ) && + ## + ## pos: 7258 7332 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { match_variable => '@' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1426} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1424} ) or 1 ) + && ## + ## pos: 7338 7462 + ( + ## + ## pos: 7338 7359 + ( + ( ( $pad{I1427} = $pos or 1 ) && + + ## + ## pos: 7347 7349 + ( ( substr( $s, $pos, 1 ) eq '^' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1427} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 7359 7393 + ( + ( ( $pad{I1428} = $pos or 1 ) && + ## + ## pos: 7360 7382 + ( + ( $pad{I1429} = $pos or 1 ) + && ( + + ## + ## pos: 7360 7370 + ( ( $pad{I1430} = $pos or 1 ) && + ## + ## pos: 7361 7369 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1430} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1429} ) or 1 ) + && + ## + ## pos: 7371 7374 + ( ( $pad{I1431} = $pos or 1 ) && + + ## + ## pos: 7372 7373 + ( ( substr( $s, $pos, 1 ) eq '_' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1431} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1429} ) or 1 ) + && ## + ## pos: 7375 7382 + ( + + ## + ## pos: 7375 7379 + ( ( $pad{I1432} = $pos or 1 ) && + + ## + ## pos: 7376 7378 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1432} ) && 0 ) ) + ## + + && + + ## + ## pos: 7379 7382 + ( ( $pad{I1433} = $pos or 1 ) && + + ## + ## pos: 7379 7381 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1433} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1428} ) && 0 ) ) + && do { while ( + ( ( $pad{I1428} = $pos or 1 ) && + ## + ## pos: 7360 7382 + ( + ( $pad{I1429} = $pos or 1 ) + && ( + + ## + ## pos: 7360 7370 + ( ( $pad{I1430} = $pos or 1 ) && + ## + ## pos: 7361 7369 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1430} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1429} ) or 1 ) + && + ## + ## pos: 7371 7374 + ( ( $pad{I1431} = $pos or 1 ) && + + ## + ## pos: 7372 7373 + ( ( substr( $s, $pos, 1 ) eq '_' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1431} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1429} ) or 1 ) + && ## + ## pos: 7375 7382 + ( + + ## + ## pos: 7375 7379 + ( ( $pad{I1432} = $pos or 1 ) && + + ## + ## pos: 7376 7378 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1432} ) && 0 ) ) + ## + + && + + ## + ## pos: 7379 7382 + ( ( $pad{I1433} = $pos or 1 ) && + + ## + ## pos: 7379 7381 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1433} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1428} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 7393 7462 + ( ( $pad{I1434} = $pos or 1 ) && + ## + ## pos: 7393 7461 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { variable => '@' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1434} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $variables{'@'} = sub { var3($_[1], $_[0], $_[2], $_[3]) }; + +# token var4 +*var4 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 7553 7773 + ( + ( $pad{I1435} = $pos or 1 ) + && ( + ## + ## pos: 7553 7649 + ( + ## + ## pos: 7553 7571 + ( + ( ( $pad{I1436} = $pos or 1 ) && + ## + ## pos: 7553 7561 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->digit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1436} ) && 0 ) ) + && do { while ( + ( ( $pad{I1436} = $pos or 1 ) && + ## + ## pos: 7553 7561 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->digit( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1436} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 7571 7649 + ( ( $pad{I1437} = $pos or 1 ) && + ## + ## pos: 7571 7644 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { match_variable => '%' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to] } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1437} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1435} ) or 1 ) + && ## + ## pos: 7650 7773 + ( + ## + ## pos: 7650 7671 + ( + ( ( $pad{I1438} = $pos or 1 ) && + + ## + ## pos: 7659 7661 + ( ( substr( $s, $pos, 1 ) eq '^' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1438} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 7671 7705 + ( + ( ( $pad{I1439} = $pos or 1 ) && + ## + ## pos: 7672 7694 + ( + ( $pad{I1440} = $pos or 1 ) + && ( + + ## + ## pos: 7672 7682 + ( ( $pad{I1441} = $pos or 1 ) && + ## + ## pos: 7673 7681 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1441} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1440} ) or 1 ) + && + ## + ## pos: 7683 7686 + ( ( $pad{I1442} = $pos or 1 ) && + + ## + ## pos: 7684 7685 + ( ( substr( $s, $pos, 1 ) eq '_' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1442} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1440} ) or 1 ) + && ## + ## pos: 7687 7694 + ( + + ## + ## pos: 7687 7691 + ( ( $pad{I1443} = $pos or 1 ) && + + ## + ## pos: 7688 7690 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1443} ) && 0 ) ) + ## + + && + + ## + ## pos: 7691 7694 + ( ( $pad{I1444} = $pos or 1 ) && + + ## + ## pos: 7691 7693 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1444} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1439} ) && 0 ) ) + && do { while ( + ( ( $pad{I1439} = $pos or 1 ) && + ## + ## pos: 7672 7694 + ( + ( $pad{I1440} = $pos or 1 ) + && ( + + ## + ## pos: 7672 7682 + ( ( $pad{I1441} = $pos or 1 ) && + ## + ## pos: 7673 7681 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->alnum( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1441} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1440} ) or 1 ) + && + ## + ## pos: 7683 7686 + ( ( $pad{I1442} = $pos or 1 ) && + + ## + ## pos: 7684 7685 + ( ( substr( $s, $pos, 1 ) eq '_' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1442} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1440} ) or 1 ) + && ## + ## pos: 7687 7694 + ( + + ## + ## pos: 7687 7691 + ( ( $pad{I1443} = $pos or 1 ) && + + ## + ## pos: 7688 7690 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1443} ) && 0 ) ) + ## + + && + + ## + ## pos: 7691 7694 + ( ( $pad{I1444} = $pos or 1 ) && + + ## + ## pos: 7691 7693 + ( ( substr( $s, $pos, 1 ) eq ':' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1444} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1439} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 7705 7773 + ( ( $pad{I1445} = $pos or 1 ) && + ## + ## pos: 7705 7772 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { variable => '%' . $_[0], _pos => [$_[0]->from - 1, $_[0]->to] } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1445} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $variables{'%'} = sub { var4($_[1], $_[0], $_[2], $_[3]) }; + +# token term1 +*term1 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 7974 8124 + ( ( $pad{I1446} = $pos or 1 ) && + ## + ## pos: 7974 8123 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { metasyntax => { + metasyntax => 'null', + }, + _pos => [ $_[0]->from, $_[0]->to ], + } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1446} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'{*}'} = sub { term1($_[1], $_[0], $_[2], $_[3]) }; + +# token term2 +*term2 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 8220 8435 + ( + + ## + ## pos: 8220 8235 + ( ( $pad{I1447} = $pos or 1 ) && + ## + ## pos: 8220 8230 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->literal( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1447} ) && 0 ) ) + ## + + && + + ## + ## pos: 8235 8246 + ( ( $pad{I1448} = $pos or 1 ) && + + ## + ## pos: 8235 8237 + ( ( substr( $s, $pos, 1 ) eq chr(39) ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1448} ) && 0 ) ) + ## + + && + + ## + ## pos: 8246 8435 + ( ( $pad{I1449} = $pos or 1 ) && + ## + ## pos: 8246 8434 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { + metasyntax => { + metasyntax => '\'' . ${$_[0]}, + }, + _pos => [ $_[0]->from - 1, $_[0]->to ], + }; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1449} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'\''} = sub { term2($_[1], $_[0], $_[2], $_[3]) }; + +# token term3 +*term3 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 8530 8646 + ( + + ## + ## pos: 8530 8537 + ( ( $pad{I1450} = $pos or 1 ) && + ## + ## pos: 8530 8536 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1450} ) && 0 ) ) + ## + + && + + ## + ## pos: 8537 8548 + ( ( $pad{I1451} = $pos or 1 ) && + + ## + ## pos: 8537 8539 + ( ( substr( $s, $pos, 1 ) eq ')' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1451} ) && 0 ) ) + ## + + && + + ## + ## pos: 8548 8646 + ( ( $pad{I1452} = $pos or 1 ) && + ## + ## pos: 8548 8645 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { capturing_group => ${ $_[0]->{qw(rule)} }, + _pos => [ $_[0]->from - 1, $_[0]->to ], }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1452} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'('} = sub { term3($_[1], $_[0], $_[2], $_[3]) }; + +# token term4 +*term4 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 8740 8861 + ( + + ## + ## pos: 8740 8748 + ( ( $pad{I1453} = $pos or 1 ) && + ## + ## pos: 8740 8746 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1453} ) && 0 ) ) + ## + + && + + ## + ## pos: 8748 8761 + ( ( $pad{I1454} = $pos or 1 ) && + + ## + ## pos: 8748 8752 + ( ( substr( $s, $pos, 2 ) eq ')>' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1454} ) && 0 ) ) + ## + + && + + ## + ## pos: 8761 8861 + ( ( $pad{I1455} = $pos or 1 ) && + ## + ## pos: 8761 8860 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { capture_as_result => ${ $_[0]->{qw(rule)} }, + _pos => [ $_[0]->from - 2, $_[0]->to ], }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1455} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'<('} = sub { term4($_[1], $_[0], $_[2], $_[3]) }; + +# token term5 +*term5 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 8956 9216 + ( + + ## + ## pos: 8956 8977 + ( ( $pad{I1456} = $pos or 1 ) && + ## + ## pos: 8956 8968 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_class( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_class'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1456} ) && 0 ) ) + ## + + && + ## + ## pos: 8977 9010 + do { while ( + ( ( $pad{I1457} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 8978 8999 + ( + + ## + ## pos: 8978 8986 + ( ( $pad{I1458} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[+-]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1458} ) && 0 ) ) + ## + + && + + ## + ## pos: 8986 8999 + ( ( $pad{I1459} = $pos or 1 ) && + ## + ## pos: 8986 8998 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_class( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_class'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1459} ) && 0 ) ) + ## + + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + if ( $bool ) { + push @{ $match[ 0 ] }, Pugs::Runtime::Match->new( $hash ); + } + $bool; + } + ## + || ( ( $pos = $pad{I1457} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 9010 9021 + ( ( $pad{I1460} = $pos or 1 ) && + + ## + ## pos: 9010 9012 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1460} ) && 0 ) ) + ## + + && + + ## + ## pos: 9021 9216 + ( ( $pad{I1461} = $pos or 1 ) && + ## + ## pos: 9021 9215 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { + _pos => [ $_[0]->from - 2, $_[0]->to ], + char_class => [ + '+' . $_[0]->{qw(char_class)}, + @{$_[0]->[0]}, # TODO - stringify + ] } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1461} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'<+'} = sub { term5($_[1], $_[0], $_[2], $_[3]) }; + +# token term6 +*term6 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 9311 9571 + ( + + ## + ## pos: 9311 9332 + ( ( $pad{I1462} = $pos or 1 ) && + ## + ## pos: 9311 9323 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_class( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_class'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1462} ) && 0 ) ) + ## + + && + ## + ## pos: 9332 9365 + do { while ( + ( ( $pad{I1463} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 9333 9354 + ( + + ## + ## pos: 9333 9341 + ( ( $pad{I1464} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[+-]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1464} ) && 0 ) ) + ## + + && + + ## + ## pos: 9341 9354 + ( ( $pad{I1465} = $pos or 1 ) && + ## + ## pos: 9341 9353 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_class( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_class'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1465} ) && 0 ) ) + ## + + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + if ( $bool ) { + push @{ $match[ 0 ] }, Pugs::Runtime::Match->new( $hash ); + } + $bool; + } + ## + || ( ( $pos = $pad{I1463} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 9365 9376 + ( ( $pad{I1466} = $pos or 1 ) && + + ## + ## pos: 9365 9367 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1466} ) && 0 ) ) + ## + + && + + ## + ## pos: 9376 9571 + ( ( $pad{I1467} = $pos or 1 ) && + ## + ## pos: 9376 9570 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { + _pos => [ $_[0]->from - 2, $_[0]->to ], + char_class => [ + '-' . $_[0]->{qw(char_class)}, + @{$_[0]->[0]}, # TODO - stringify + ] } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1467} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'<-'} = sub { term6($_[1], $_[0], $_[2], $_[3]) }; + +# token term7 +*term7 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 9666 9937 + ( + + ## + ## pos: 9666 9680 + ( ( $pad{I1468} = $pos or 1 ) && + ## + ## pos: 9666 9678 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_range( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_range'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1468} ) && 0 ) ) + ## + + && + + ## + ## pos: 9680 9691 + ( ( $pad{I1469} = $pos or 1 ) && + + ## + ## pos: 9680 9682 + ( ( substr( $s, $pos, 1 ) eq ']' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1469} ) && 0 ) ) + ## + + && + ## + ## pos: 9691 9724 + do { while ( + ( ( $pad{I1470} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 9692 9713 + ( + + ## + ## pos: 9692 9700 + ( ( $pad{I1471} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[+-]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1471} ) && 0 ) ) + ## + + && + + ## + ## pos: 9700 9713 + ( ( $pad{I1472} = $pos or 1 ) && + ## + ## pos: 9700 9712 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->char_class( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'char_class'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1472} ) && 0 ) ) + ## + + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + if ( $bool ) { + push @{ $match[ 0 ] }, Pugs::Runtime::Match->new( $hash ); + } + $bool; + } + ## + || ( ( $pos = $pad{I1470} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 9724 9735 + ( ( $pad{I1473} = $pos or 1 ) && + + ## + ## pos: 9724 9726 + ( ( substr( $s, $pos, 1 ) eq '>' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1473} ) && 0 ) ) + ## + + && + + ## + ## pos: 9735 9937 + ( ( $pad{I1474} = $pos or 1 ) && + ## + ## pos: 9735 9936 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { + _pos => [ $_[0]->from - 2, $_[0]->to ], + char_class => [ + '+[' . $_[0]->{qw(char_range)} . ']', + @{$_[0]->[0]}, # TODO - stringify + ] } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1474} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'<['} = sub { term7($_[1], $_[0], $_[2], $_[3]) }; + +# token term8 +*term8 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 10032 10091 + ( + + ## + ## pos: 10032 10059 + ( ( $pad{I1475} = $pos or 1 ) && + ## + ## pos: 10032 10050 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->parse_metasyntax( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'parse_metasyntax'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1475} ) && 0 ) ) + ## + + && + + ## + ## pos: 10059 10091 + ( ( $pad{I1476} = $pos or 1 ) && + ## + ## pos: 10059 10090 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return ${ $_[0]->{qw(parse_metasyntax)} } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1476} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'<'} = sub { term8($_[1], $_[0], $_[2], $_[3]) }; + +# token term9 +*term9 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 10185 10375 + ( + + ## + ## pos: 10185 10200 + ( ( $pad{I1477} = $pos or 1 ) && + ## + ## pos: 10185 10198 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->parsed_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'parsed_code'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1477} ) && 0 ) ) + ## + + && + + ## + ## pos: 10200 10211 + ( ( $pad{I1478} = $pos or 1 ) && + + ## + ## pos: 10200 10202 + ( ( substr( $s, $pos, 1 ) eq '}' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1478} ) && 0 ) ) + ## + + && + + ## + ## pos: 10211 10375 + ( ( $pad{I1479} = $pos or 1 ) && + ## + ## pos: 10211 10374 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { closure => { + closure => ${ $_[0]->{qw(parsed_code)} }, + modifier => 'plain', + }, + _pos => [$_[0]->from - 1, $_[0]->to], + } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1479} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'{'} = sub { term9($_[1], $_[0], $_[2], $_[3]) }; + +# token term10 +*term10 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 10470 10521 + ( + + ## + ## pos: 10470 10493 + ( ( $pad{I1480} = $pos or 1 ) && + ## + ## pos: 10470 10484 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->special_char( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'special_char'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1480} ) && 0 ) ) + ## + + && + + ## + ## pos: 10493 10521 + ( ( $pad{I1481} = $pos or 1 ) && + ## + ## pos: 10493 10520 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return ${ $_[0]->{qw(special_char)} } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1481} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'\\'} = sub { term10($_[1], $_[0], $_[2], $_[3]) }; + +# token term11 +*term11 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 10618 10677 + ( ( $pad{I1482} = $pos or 1 ) && + ## + ## pos: 10618 10676 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { 'dot' => 1, _pos => [$_[0]->from - 1, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1482} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'.'} = sub { term11($_[1], $_[0], $_[2], $_[3]) }; + +# token term12 +*term12 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 10773 10811 + ( + + ## + ## pos: 10773 10780 + ( ( $pad{I1483} = $pos or 1 ) && + ## + ## pos: 10773 10779 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1483} ) && 0 ) ) + ## + + && + + ## + ## pos: 10780 10791 + ( ( $pad{I1484} = $pos or 1 ) && + + ## + ## pos: 10780 10782 + ( ( substr( $s, $pos, 1 ) eq ']' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1484} ) && 0 ) ) + ## + + && + + ## + ## pos: 10791 10811 + ( ( $pad{I1485} = $pos or 1 ) && + ## + ## pos: 10791 10810 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return ${ $_[0]->{qw(rule)} } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1485} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'['} = sub { term12($_[1], $_[0], $_[2], $_[3]) }; + +# token term13 +*term13 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 10899 10962 + ( ( $pad{I1486} = $pos or 1 ) && + ## + ## pos: 10899 10961 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => ':::', _pos => [$_[0]->from - 3, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1486} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':::'} = sub { term13($_[1], $_[0], $_[2], $_[3]) }; + +# token term14 +*term14 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 11052 11114 + ( ( $pad{I1487} = $pos or 1 ) && + ## + ## pos: 11052 11113 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => ':?', _pos => [$_[0]->from - 2, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1487} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':?'} = sub { term14($_[1], $_[0], $_[2], $_[3]) }; + +# token term15 +*term15 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 11203 11265 + ( ( $pad{I1488} = $pos or 1 ) && + ## + ## pos: 11203 11264 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => ':+', _pos => [$_[0]->from - 2, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1488} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':+'} = sub { term15($_[1], $_[0], $_[2], $_[3]) }; + +# token term16 +*term16 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 11354 11416 + ( ( $pad{I1489} = $pos or 1 ) && + ## + ## pos: 11354 11415 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => '::', _pos => [$_[0]->from - 2, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1489} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'::'} = sub { term16($_[1], $_[0], $_[2], $_[3]) }; + +# token term17 +*term17 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 11505 11566 + ( ( $pad{I1490} = $pos or 1 ) && + ## + ## pos: 11505 11565 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => ':', _pos => [$_[0]->from - 2, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1490} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':'} = sub { term17($_[1], $_[0], $_[2], $_[3]) }; + +# token term18 +*term18 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 11654 11716 + ( ( $pad{I1491} = $pos or 1 ) && + ## + ## pos: 11654 11715 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => '$$', _pos => [$_[0]->from - 2, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1491} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'$$'} = sub { term18($_[1], $_[0], $_[2], $_[3]) }; + +# token term19 +*term19 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 11805 11867 + ( ( $pad{I1492} = $pos or 1 ) && + ## + ## pos: 11805 11866 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => '$', _pos => [$_[0]->from - 1, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1492} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'$'} = sub { term19($_[1], $_[0], $_[2], $_[3]) }; + +# token term20 +*term20 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 11955 12017 + ( ( $pad{I1493} = $pos or 1 ) && + ## + ## pos: 11955 12016 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => '^^', _pos => [$_[0]->from - 2, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1493} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'^^'} = sub { term20($_[1], $_[0], $_[2], $_[3]) }; + +# token term21 +*term21 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 12106 12167 + ( ( $pad{I1494} = $pos or 1 ) && + ## + ## pos: 12106 12166 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => '^', _pos => [$_[0]->from - 1, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1494} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'^'} = sub { term21($_[1], $_[0], $_[2], $_[3]) }; + +# token term22 +*term22 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 12255 12317 + ( ( $pad{I1495} = $pos or 1 ) && + ## + ## pos: 12255 12316 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => '>>', _pos => [$_[0]->from - 2, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1495} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'>>'} = sub { term22($_[1], $_[0], $_[2], $_[3]) }; + +# Code block from grammar spec + $rule_terms{'»'} = sub { term22($_[1], $_[0], $_[2], $_[3]) }; + +# token term24 +*term24 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + + ## + ## pos: 12559 12621 + ( ( $pad{I1496} = $pos or 1 ) && + ## + ## pos: 12559 12620 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { colon => '<<', _pos => [$_[0]->from - 2, $_[0]->to], } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1496} ) && 0 ) ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{'<<'} = sub { term24($_[1], $_[0], $_[2], $_[3]) }; + +# Code block from grammar spec + $rule_terms{'«'} = sub { term24($_[1], $_[0], $_[2], $_[3]) }; + +# token term26 +*term26 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 12871 13048 + ( + + ## + ## pos: 12871 12877 + ( ( $pad{I1497} = $pos or 1 ) && + ## + ## pos: 12871 12876 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1497} ) && 0 ) ) + ## + + && + + ## + ## pos: 12877 12892 + ( ( $pad{I1498} = $pos or 1 ) && + ## + ## pos: 12877 12883 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1498} ) && 0 ) ) + ## + + && + + ## + ## pos: 12892 13048 + ( ( $pad{I1499} = $pos or 1 ) && + ## + ## pos: 12892 13047 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { + modifier => { + modifier => 'ignorecase', + rule => ${ $_[0]->{qw(rule)} }, + } + }, + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1499} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':i'} = sub { term26($_[1], $_[0], $_[2], $_[3]) }; + +# Code block from grammar spec + $rule_terms{':ignorecase'} = sub { term26($_[1], $_[0], $_[2], $_[3]) }; + +# token term28 +*term28 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 13328 13405 + ( + + ## + ## pos: 13328 13334 + ( ( $pad{I1500} = $pos or 1 ) && + ## + ## pos: 13328 13333 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1500} ) && 0 ) ) + ## + + && + + ## + ## pos: 13334 13349 + ( ( $pad{I1501} = $pos or 1 ) && + ## + ## pos: 13334 13340 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1501} ) && 0 ) ) + ## + + && + + ## + ## pos: 13349 13405 + ( ( $pad{I1502} = $pos or 1 ) && + ## + ## pos: 13349 13404 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { modifier => 'sigspace', rule => ${ $_[0]->{qw(rule)} } } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1502} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':s'} = sub { term28($_[1], $_[0], $_[2], $_[3]) }; + +# Code block from grammar spec + $rule_terms{':sigspace'} = sub { term28($_[1], $_[0], $_[2], $_[3]) }; + +# token term30 +*term30 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 13684 13758 + ( + + ## + ## pos: 13684 13690 + ( ( $pad{I1503} = $pos or 1 ) && + ## + ## pos: 13684 13689 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1503} ) && 0 ) ) + ## + + && + + ## + ## pos: 13690 13705 + ( ( $pad{I1504} = $pos or 1 ) && + ## + ## pos: 13690 13696 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1504} ) && 0 ) ) + ## + + && + + ## + ## pos: 13705 13758 + ( ( $pad{I1505} = $pos or 1 ) && + ## + ## pos: 13705 13757 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { modifier => 'Perl5', rule => ${ $_[0]->{qw(rule)} } } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1505} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':P5'} = sub { term30($_[1], $_[0], $_[2], $_[3]) }; + +# Code block from grammar spec + $rule_terms{':Perl5'} = sub { term30($_[1], $_[0], $_[2], $_[3]) }; + +# token term32 +*term32 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 14031 14105 + ( + + ## + ## pos: 14031 14037 + ( ( $pad{I1506} = $pos or 1 ) && + ## + ## pos: 14031 14036 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1506} ) && 0 ) ) + ## + + && + + ## + ## pos: 14037 14052 + ( ( $pad{I1507} = $pos or 1 ) && + ## + ## pos: 14037 14043 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1507} ) && 0 ) ) + ## + + && + + ## + ## pos: 14052 14105 + ( ( $pad{I1508} = $pos or 1 ) && + ## + ## pos: 14052 14104 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { modifier => 'bytes', rule => ${ $_[0]->{qw(rule)} } } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1508} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':bytes'} = sub { term32($_[1], $_[0], $_[2], $_[3]) }; + +# token term33 +*term33 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 14206 14280 + ( + + ## + ## pos: 14206 14212 + ( ( $pad{I1509} = $pos or 1 ) && + ## + ## pos: 14206 14211 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1509} ) && 0 ) ) + ## + + && + + ## + ## pos: 14212 14227 + ( ( $pad{I1510} = $pos or 1 ) && + ## + ## pos: 14212 14218 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1510} ) && 0 ) ) + ## + + && + + ## + ## pos: 14227 14280 + ( ( $pad{I1511} = $pos or 1 ) && + ## + ## pos: 14227 14279 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { modifier => 'codes', rule => ${ $_[0]->{qw(rule)} } } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1511} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':codes'} = sub { term33($_[1], $_[0], $_[2], $_[3]) }; + +# token term34 +*term34 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 14381 14456 + ( + + ## + ## pos: 14381 14387 + ( ( $pad{I1512} = $pos or 1 ) && + ## + ## pos: 14381 14386 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1512} ) && 0 ) ) + ## + + && + + ## + ## pos: 14387 14402 + ( ( $pad{I1513} = $pos or 1 ) && + ## + ## pos: 14387 14393 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1513} ) && 0 ) ) + ## + + && + + ## + ## pos: 14402 14456 + ( ( $pad{I1514} = $pos or 1 ) && + ## + ## pos: 14402 14455 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { modifier => 'graphs', rule => ${ $_[0]->{qw(rule)} } } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1514} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':graphs'} = sub { term34($_[1], $_[0], $_[2], $_[3]) }; + +# token term35 +*term35 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 14558 14633 + ( + + ## + ## pos: 14558 14564 + ( ( $pad{I1515} = $pos or 1 ) && + ## + ## pos: 14558 14563 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1515} ) && 0 ) ) + ## + + && + + ## + ## pos: 14564 14579 + ( ( $pad{I1516} = $pos or 1 ) && + ## + ## pos: 14564 14570 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1516} ) && 0 ) ) + ## + + && + + ## + ## pos: 14579 14633 + ( ( $pad{I1517} = $pos or 1 ) && + ## + ## pos: 14579 14632 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { modifier => 'langs', rule => ${ $_[0]->{qw(rule)} } } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1517} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# Code block from grammar spec + $rule_terms{':langs'} = sub { term35($_[1], $_[0], $_[2], $_[3]) }; + +# token term +*term = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 14728 15530 + ( + ( $pad{I1518} = $pos or 1 ) + && ( + ## + ## pos: 14729 15207 + ( + + ## + ## pos: 14729 14772 + ( ( $pad{I1519} = $pos or 1 ) && + ## + ## pos: 14731 14764 + do{ + my $match = + ## + ## pos: 14731 14764 + do { + our $I1520; + our $I1520_sizes; + unless ( $I1520 ) { + my $hash = \%Pugs::Grammar::Rule::variables; + my %sizes = map { length($_) => 1 } keys %$hash; + $I1520_sizes = [ sort { $b <=> $a } keys %sizes ]; + $I1520 = $hash; + } + my $match = 0; + my $key; + for ( @$I1520_sizes ) { + $key = ( $pos <= length( $s ) + ? substr( $s, $pos, $_ ) + : '' ); + if ( exists $I1520->{$key} ) { + #$named{KEY} = $key; + #$::_V6_MATCH_ = $m; + #print "m: ", Dumper( $::_V6_MATCH_->data ) + # if ( $key eq 'until' ); + $match = Pugs::Runtime::Regex::preprocess_hash( $I1520, $key )->( $s, $grammar, { p => ( $pos + $_ ), positionals => [ ], args => { KEY => $key } }, undef ); + last if $match; + } + } + if ( $match ) { + $pos = $match->to; + #print "match: $key at $pos = ", Dumper( $match->data ); + $bool = 1; + }; # else { $bool = 0 } + $match; + } + ## + ; + if ( $match ) { $named{'Pugs::Grammar::Rule::variables'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1519} ) && 0 ) ) + ## + + && + + ## + ## pos: 14772 15207 + ( ( $pad{I1521} = $pos or 1 ) && + ## + ## pos: 14773 15201 + ( + ( $pad{I1522} = $pos or 1 ) + && ( + ## + ## pos: 14773 15114 + ( + ## + ## pos: 14773 14782 + ( + ( ( $pad{I1523} = $pos or 1 ) && + ## + ## pos: 14775 14780 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1523} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 14782 14787 + ( ( $pad{I1524} = $pos or 1 ) && + + ## + ## pos: 14782 14786 + ( ( substr( $s, $pos, 2 ) eq ':=' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1524} ) && 0 ) ) + ## + + && + ## + ## pos: 14787 14794 + ( + ( ( $pad{I1525} = $pos or 1 ) && + ## + ## pos: 14787 14792 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1525} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 14794 14825 + ( ( $pad{I1526} = $pos or 1 ) && + ## + ## pos: 14794 14814 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->named_capture_body( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'named_capture_body'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1526} ) && 0 ) ) + ## + + && + + ## + ## pos: 14825 15114 + ( ( $pad{I1527} = $pos or 1 ) && + ## + ## pos: 14825 15106 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + return { named_capture => { + rule => ${ $_[0]->{qw(named_capture_body)} }, + ident => ${ $_[0]->{qw(Pugs::Grammar::Rule::variables)} }, + }, + _pos => [ $_[0]->from, $_[0]->to ], + }; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1527} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1522} ) or 1 ) + && + ## + ## pos: 15115 15201 + ( ( $pad{I1528} = $pos or 1 ) && + ## + ## pos: 15126 15193 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + return ${ $_[0]->{qw(Pugs::Grammar::Rule::variables)} } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1528} ) && 0 ) ) + ## + + ) + ) + ## + || ( ( $pos = $pad{I1521} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1518} ) or 1 ) + && ## + ## pos: 15208 15376 + ( + + ## + ## pos: 15208 15253 + ( ( $pad{I1529} = $pos or 1 ) && + ## + ## pos: 15210 15244 + do{ + my $match = + ## + ## pos: 15210 15244 + do { + our $I1530; + our $I1530_sizes; + unless ( $I1530 ) { + my $hash = \%Pugs::Grammar::Rule::rule_terms; + my %sizes = map { length($_) => 1 } keys %$hash; + $I1530_sizes = [ sort { $b <=> $a } keys %sizes ]; + $I1530 = $hash; + } + my $match = 0; + my $key; + for ( @$I1530_sizes ) { + $key = ( $pos <= length( $s ) + ? substr( $s, $pos, $_ ) + : '' ); + if ( exists $I1530->{$key} ) { + #$named{KEY} = $key; + #$::_V6_MATCH_ = $m; + #print "m: ", Dumper( $::_V6_MATCH_->data ) + # if ( $key eq 'until' ); + $match = Pugs::Runtime::Regex::preprocess_hash( $I1530, $key )->( $s, $grammar, { p => ( $pos + $_ ), positionals => [ ], args => { KEY => $key } }, undef ); + last if $match; + } + } + if ( $match ) { + $pos = $match->to; + #print "match: $key at $pos = ", Dumper( $match->data ); + $bool = 1; + }; # else { $bool = 0 } + $match; + } + ## + ; + if ( $match ) { $named{'Pugs::Grammar::Rule::rule_terms'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1529} ) && 0 ) ) + ## + + && + + ## + ## pos: 15253 15376 + ( ( $pad{I1531} = $pos or 1 ) && + ## + ## pos: 15253 15371 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + #print "term: ", Dumper( $_[0]->data ); + return ${ $_[0]->{qw(Pugs::Grammar::Rule::rule_terms)} } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1531} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1518} ) or 1 ) + && ## + ## pos: 15377 15530 + ( + + ## + ## pos: 15377 15424 + ( ( $pad{I1532} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?![\]\}\)\>\:\?\+\*\|\&]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1532} ) && 0 ) ) + ## + + && + + ## + ## pos: 15424 15530 + ( ( $pad{I1533} = $pos or 1 ) && + ## + ## pos: 15424 15529 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + return { 'constant' => ${$_[0]}, + _pos => [ $_[0]->from, $_[0]->to ] } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1533} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token quant +*quant = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 15551 15665 + ( + ( $pad{I1534} = $pos or 1 ) + && ( + ## + ## pos: 15552 15643 + ( + + ## + ## pos: 15552 15560 + ( ( $pad{I1535} = $pos or 1 ) && + + ## + ## pos: 15555 15559 + ( ( substr( $s, $pos, 2 ) eq '**' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1535} ) && 0 ) ) + ## + + && + ## + ## pos: 15560 15567 + ( + ( ( $pad{I1536} = $pos or 1 ) && + ## + ## pos: 15560 15565 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1536} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 15567 15571 + ( ( $pad{I1537} = $pos or 1 ) && + + ## + ## pos: 15567 15569 + ( ( substr( $s, $pos, 1 ) eq '{' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1537} ) && 0 ) ) + ## + + && + + ## + ## pos: 15571 15586 + ( ( $pad{I1538} = $pos or 1 ) && + ## + ## pos: 15571 15584 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->parsed_code( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'parsed_code'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1538} ) && 0 ) ) + ## + + && + + ## + ## pos: 15586 15597 + ( ( $pad{I1539} = $pos or 1 ) && + + ## + ## pos: 15586 15588 + ( ( substr( $s, $pos, 1 ) eq '}' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1539} ) && 0 ) ) + ## + + && + + ## + ## pos: 15597 15643 + ( ( $pad{I1540} = $pos or 1 ) && + ## + ## pos: 15597 15638 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { closure => ${ $_[0]->{qw(parsed_code)} } } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1540} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1534} ) or 1 ) + && ## + ## pos: 15644 15665 + ( + ( ( $pad{I1541} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[\?\*\+]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1541} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token quantifier +*quantifier = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 15691 16457 + ( + + ## + ## pos: 15691 15716 + ( ( $pad{I1542} = $pos or 1 ) && + ## + ## pos: 15691 15711 + do{ + my $match = Pugs::Runtime::Match->new( do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 15704 15710 + ( + ( ( $pad{I1543} = $pos or 1 ) && + ## + ## pos: 15704 15709 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1543} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + } ); + if ( $match ) { $named{'ws1'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1542} ) && 0 ) ) + ## + + && + + ## + ## pos: 15716 15751 + ( ( $pad{I1544} = $pos or 1 ) && + ## + ## pos: 15716 15746 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = + ## + ## pos: 15726 15745 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + + ## + ## pos: 15726 15745 + ( ( $pad{I1545} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[\}\]\)]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1545} ) && 0 ) ) + ## + ; + $bool; + }; + } + ## + ? 0 : 1; + $bool; + }; + } + ## + || ( ( $pos = $pad{I1544} ) && 0 ) ) + ## + + && + + ## + ## pos: 15751 15762 + ( ( $pad{I1546} = $pos or 1 ) && + ## + ## pos: 15751 15757 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->term( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'term'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1546} ) && 0 ) ) + ## + + && + + ## + ## pos: 15762 15787 + ( ( $pad{I1547} = $pos or 1 ) && + ## + ## pos: 15762 15782 + do{ + my $match = Pugs::Runtime::Match->new( do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 15775 15781 + ( + ( ( $pad{I1548} = $pos or 1 ) && + ## + ## pos: 15775 15780 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1548} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + } ); + if ( $match ) { $named{'ws2'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1547} ) && 0 ) ) + ## + + && + + ## + ## pos: 15787 15799 + ( ( $pad{I1549} = $pos or 1 ) && + ## + ## pos: 15787 15794 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->quant( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'quant'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1549} ) && 0 ) ) + ## + + && + + ## + ## pos: 15799 15833 + ( ( $pad{I1550} = $pos or 1 ) && + ## + ## pos: 15799 15828 + do{ + my $match = Pugs::Runtime::Match->new( do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 15813 15827 + ( + ( ( $pad{I1551} = $pos or 1 ) && + ## + ( ( substr( $s, $pos ) =~ m/^((?:(?=[\?\+]))\X)/ ) + ? ( $pos += length( $1 ) or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1551} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + } ); + if ( $match ) { $named{'greedy'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1550} ) && 0 ) ) + ## + + && + + ## + ## pos: 15833 15858 + ( ( $pad{I1552} = $pos or 1 ) && + ## + ## pos: 15833 15853 + do{ + my $match = Pugs::Runtime::Match->new( do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 15846 15852 + ( + ( ( $pad{I1553} = $pos or 1 ) && + ## + ## pos: 15846 15851 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1553} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + } ); + if ( $match ) { $named{'ws3'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1552} ) && 0 ) ) + ## + + && + + ## + ## pos: 15858 16457 + ( ( $pad{I1554} = $pos or 1 ) && + ## + ## pos: 15858 16456 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + if ( + ${$_[0]->{'quant'}} eq '' + && ${$_[0]->{'greedy'}} eq '' + && ${$_[0]->{'ws1'}} eq '' + && ${$_[0]->{'ws2'}} eq '' + && ${$_[0]->{'ws3'}} eq '' + ) { + return ${$_[0]->{'term'}}; + } + return { + quant => { + term => ${$_[0]->{'term'}}, + quant => ${$_[0]->{'quant'}}, + greedy => ${$_[0]->{'greedy'}}, + ws1 => ${$_[0]->{'ws1'}}, + ws2 => ${$_[0]->{'ws2'}}, + ws3 => ${$_[0]->{'ws3'}}, + }, + _pos => [$_[0]->from, $_[0]->to], + } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1554} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token concat +*concat = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 16479 16688 + ( + ## + ## pos: 16479 16497 + ( + ( ( $pad{I1555} = $pos or 1 ) && + ## + ## pos: 16479 16491 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->quantifier( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'quantifier'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1555} ) && 0 ) ) + && do { while ( + ( ( $pad{I1555} = $pos or 1 ) && + ## + ## pos: 16479 16491 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->quantifier( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'quantifier'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1555} ) && 0 ) )) {}; $bool = 1 } + ) + ## + + && + + ## + ## pos: 16497 16688 + ( ( $pad{I1556} = $pos or 1 ) && + ## + ## pos: 16497 16687 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + my @a = map { $_->() } @{ $::_V6_MATCH_->{'quantifier'} }; + return { concat => \@a, _pos => [$_[0]->from, $_[0]->to] } + if scalar @a > 1; + return $a[0]; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1556} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token conjunctive1 +*conjunctive1 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 16716 16996 + ( + ## + ## pos: 16716 16750 + ( + ( ( $pad{I1557} = $pos or 1 ) && + ## + ## pos: 16717 16742 + ( + ## + ## pos: 16717 16725 + ( + ( ( $pad{I1558} = $pos or 1 ) && + ## + ## pos: 16718 16723 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1558} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 16725 16728 + ( ( $pad{I1559} = $pos or 1 ) && + + ## + ## pos: 16725 16727 + ( ( substr( $s, $pos, 1 ) eq '&' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1559} ) && 0 ) ) + ## + + && + + ## + ## pos: 16728 16742 + ( ( $pad{I1560} = $pos or 1 ) && + ## + ## pos: 16728 16741 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = + ## + ## pos: 16737 16740 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + + ## + ## pos: 16737 16740 + ( ( $pad{I1561} = $pos or 1 ) && + + ## + ## pos: 16737 16739 + ( ( substr( $s, $pos, 1 ) eq '&' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1561} ) && 0 ) ) + ## + ; + $bool; + }; + } + ## + ? 0 : 1; + $bool; + }; + } + ## + || ( ( $pos = $pad{I1560} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1557} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 16750 16768 + ( + ( ( $pad{I1562} = $pos or 1 ) && + ## + ## pos: 16750 16758 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->concat( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'concat'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1562} ) && 0 ) ) + ) + ## + + && + ## + ## pos: 16768 16817 + do { while ( + ( ( $pad{I1563} = $pos or 1 ) && + ## + ## pos: 16769 16809 + ( + + ## + ## pos: 16769 16781 + ( ( $pad{I1564} = $pos or 1 ) && + + ## + ## pos: 16778 16780 + ( ( substr( $s, $pos, 1 ) eq '&' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1564} ) && 0 ) ) + ## + + && + + ## + ## pos: 16781 16796 + ( ( $pad{I1565} = $pos or 1 ) && + ## + ## pos: 16781 16794 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = + ## + ## pos: 16790 16793 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + + ## + ## pos: 16790 16793 + ( ( $pad{I1566} = $pos or 1 ) && + + ## + ## pos: 16790 16792 + ( ( substr( $s, $pos, 1 ) eq '&' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1566} ) && 0 ) ) + ## + ; + $bool; + }; + } + ## + ? 0 : 1; + $bool; + }; + } + ## + || ( ( $pos = $pad{I1565} ) && 0 ) ) + ## + + && + + ## + ## pos: 16796 16809 + ( ( $pad{I1567} = $pos or 1 ) && + ## + ## pos: 16796 16804 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->concat( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'concat'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1567} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1563} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 16817 16996 + ( ( $pad{I1568} = $pos or 1 ) && + ## + ## pos: 16817 16995 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + my @a = map { $$_ } @{ $::_V6_MATCH_->{'concat'} }; + return { conjunctive1 => \@a, _pos => [$_[0]->from, $_[0]->to] } if scalar @a > 1; + return $a[0]; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1568} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token disjunctive1 +*disjunctive1 = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 17024 17313 + ( + ## + ## pos: 17024 17058 + ( + ( ( $pad{I1569} = $pos or 1 ) && + ## + ## pos: 17025 17050 + ( + ## + ## pos: 17025 17033 + ( + ( ( $pad{I1570} = $pos or 1 ) && + ## + ## pos: 17026 17031 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1570} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 17033 17036 + ( ( $pad{I1571} = $pos or 1 ) && + + ## + ## pos: 17033 17035 + ( ( substr( $s, $pos, 1 ) eq '|' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1571} ) && 0 ) ) + ## + + && + + ## + ## pos: 17036 17050 + ( ( $pad{I1572} = $pos or 1 ) && + ## + ## pos: 17036 17049 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = + ## + ## pos: 17045 17048 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + + ## + ## pos: 17045 17048 + ( ( $pad{I1573} = $pos or 1 ) && + + ## + ## pos: 17045 17047 + ( ( substr( $s, $pos, 1 ) eq '|' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1573} ) && 0 ) ) + ## + ; + $bool; + }; + } + ## + ? 0 : 1; + $bool; + }; + } + ## + || ( ( $pos = $pad{I1572} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1569} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 17058 17082 + ( + ( ( $pad{I1574} = $pos or 1 ) && + ## + ## pos: 17058 17072 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->conjunctive1( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'conjunctive1'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1574} ) && 0 ) ) + ) + ## + + && + ## + ## pos: 17082 17136 + do { while ( + ( ( $pad{I1575} = $pos or 1 ) && + ## + ## pos: 17083 17128 + ( + + ## + ## pos: 17083 17095 + ( ( $pad{I1576} = $pos or 1 ) && + + ## + ## pos: 17092 17094 + ( ( substr( $s, $pos, 1 ) eq '|' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1576} ) && 0 ) ) + ## + + && + + ## + ## pos: 17095 17109 + ( ( $pad{I1577} = $pos or 1 ) && + ## + ## pos: 17095 17108 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = + ## + ## pos: 17104 17107 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + + ## + ## pos: 17104 17107 + ( ( $pad{I1578} = $pos or 1 ) && + + ## + ## pos: 17104 17106 + ( ( substr( $s, $pos, 1 ) eq '|' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1578} ) && 0 ) ) + ## + ; + $bool; + }; + } + ## + ? 0 : 1; + $bool; + }; + } + ## + || ( ( $pos = $pad{I1577} ) && 0 ) ) + ## + + && + + ## + ## pos: 17109 17128 + ( ( $pad{I1579} = $pos or 1 ) && + ## + ## pos: 17109 17123 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->conjunctive1( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'conjunctive1'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1579} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1575} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 17136 17313 + ( ( $pad{I1580} = $pos or 1 ) && + ## + ## pos: 17136 17312 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + my @a = map { $$_ } @{ $::_V6_MATCH_->{'conjunctive1'} }; + return { alt1 => \@a, _pos => [$_[0]->from, $_[0]->to] } if scalar @a > 1; + return $a[0]; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1580} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token conjunctive +*conjunctive = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 17340 17614 + ( + ## + ## pos: 17340 17363 + ( + ( ( $pad{I1581} = $pos or 1 ) && + ## + ## pos: 17341 17355 + ( + ## + ## pos: 17341 17349 + ( + ( ( $pad{I1582} = $pos or 1 ) && + ## + ## pos: 17342 17347 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1582} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 17349 17352 + ( ( $pad{I1583} = $pos or 1 ) && + + ## + ## pos: 17349 17351 + ( ( substr( $s, $pos, 1 ) eq '&' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1583} ) && 0 ) ) + ## + + && + + ## + ## pos: 17352 17355 + ( ( $pad{I1584} = $pos or 1 ) && + + ## + ## pos: 17352 17354 + ( ( substr( $s, $pos, 1 ) eq '&' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1584} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1581} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 17363 17387 + ( + ( ( $pad{I1585} = $pos or 1 ) && + ## + ## pos: 17363 17377 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->disjunctive1( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'disjunctive1'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1585} ) && 0 ) ) + ) + ## + + && + ## + ## pos: 17387 17430 + do { while ( + ( ( $pad{I1586} = $pos or 1 ) && + ## + ## pos: 17388 17422 + ( + + ## + ## pos: 17388 17400 + ( ( $pad{I1587} = $pos or 1 ) && + + ## + ## pos: 17397 17399 + ( ( substr( $s, $pos, 1 ) eq '&' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1587} ) && 0 ) ) + ## + + && + + ## + ## pos: 17400 17403 + ( ( $pad{I1588} = $pos or 1 ) && + + ## + ## pos: 17400 17402 + ( ( substr( $s, $pos, 1 ) eq '&' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1588} ) && 0 ) ) + ## + + && + + ## + ## pos: 17403 17422 + ( ( $pad{I1589} = $pos or 1 ) && + ## + ## pos: 17403 17417 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->disjunctive1( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'disjunctive1'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1589} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1586} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 17430 17614 + ( ( $pad{I1590} = $pos or 1 ) && + ## + ## pos: 17430 17613 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + my @a = map { $$_ } @{ $::_V6_MATCH_->{'disjunctive1'} }; + return { conjunctive => \@a, _pos => [$_[0]->from, $_[0]->to] } if scalar @a > 1; + return $a[0]; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1590} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token rule +*rule = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 17634 17898 + ( + ## + ## pos: 17634 17657 + ( + ( ( $pad{I1591} = $pos or 1 ) && + ## + ## pos: 17635 17649 + ( + ## + ## pos: 17635 17643 + ( + ( ( $pad{I1592} = $pos or 1 ) && + ## + ## pos: 17636 17641 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1592} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 17643 17646 + ( ( $pad{I1593} = $pos or 1 ) && + + ## + ## pos: 17643 17645 + ( ( substr( $s, $pos, 1 ) eq '|' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1593} ) && 0 ) ) + ## + + && + + ## + ## pos: 17646 17649 + ( ( $pad{I1594} = $pos or 1 ) && + + ## + ## pos: 17646 17648 + ( ( substr( $s, $pos, 1 ) eq '|' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1594} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1591} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 17657 17680 + ( + ( ( $pad{I1595} = $pos or 1 ) && + ## + ## pos: 17657 17670 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->conjunctive( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'conjunctive'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1595} ) && 0 ) ) + ) + ## + + && + ## + ## pos: 17680 17722 + do { while ( + ( ( $pad{I1596} = $pos or 1 ) && + ## + ## pos: 17681 17714 + ( + + ## + ## pos: 17681 17693 + ( ( $pad{I1597} = $pos or 1 ) && + + ## + ## pos: 17690 17692 + ( ( substr( $s, $pos, 1 ) eq '|' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1597} ) && 0 ) ) + ## + + && + + ## + ## pos: 17693 17696 + ( ( $pad{I1598} = $pos or 1 ) && + + ## + ## pos: 17693 17695 + ( ( substr( $s, $pos, 1 ) eq '|' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1598} ) && 0 ) ) + ## + + && + + ## + ## pos: 17696 17714 + ( ( $pad{I1599} = $pos or 1 ) && + ## + ## pos: 17696 17709 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->conjunctive( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'conjunctive'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1599} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1596} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 17722 17898 + ( ( $pad{I1600} = $pos or 1 ) && + ## + ## pos: 17722 17897 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { + my @a = map { $$_ } @{ $::_V6_MATCH_->{'conjunctive'} }; + return { alt => \@a, _pos => [$_[0]->from, $_[0]->to], } if scalar @a > 1; + return $a[0]; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1600} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token named_regex +*named_regex = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 17925 18145 + ( + + ## + ## pos: 17925 17960 + ( ( $pad{I1601} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 17926 17954 + ( + ( $pad{I1602} = $pos or 1 ) + && ( + + ## + ## pos: 17926 17935 + ( ( $pad{I1603} = $pos or 1 ) && + + ## + ## pos: 17927 17934 + ( ( substr( $s, $pos, 5 ) eq 'token' ) + ? ( $pos += 5 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1603} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1602} ) or 1 ) + && + ## + ## pos: 17936 17945 + ( ( $pad{I1604} = $pos or 1 ) && + + ## + ## pos: 17937 17944 + ( ( substr( $s, $pos, 5 ) eq 'regex' ) + ? ( $pos += 5 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1604} ) && 0 ) ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1602} ) or 1 ) + && + ## + ## pos: 17946 17954 + ( ( $pad{I1605} = $pos or 1 ) && + + ## + ## pos: 17947 17953 + ( ( substr( $s, $pos, 4 ) eq 'rule' ) + ? ( $pos += 4 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1605} ) && 0 ) ) + ## + + ) + ) + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + || ( ( $pos = $pad{I1601} ) && 0 ) ) + ## + + && + + ## + ## pos: 17960 17966 + ( ( $pad{I1606} = $pos or 1 ) && + ## + ## pos: 17960 17965 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1606} ) && 0 ) ) + ## + + && + + ## + ## pos: 17966 17974 + ( ( $pad{I1607} = $pos or 1 ) && + ## + ## pos: 17966 17973 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ident( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'ident'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1607} ) && 0 ) ) + ## + + && + ## + ## pos: 17974 17981 + ( + ( ( $pad{I1608} = $pos or 1 ) && + ## + ## pos: 17974 17979 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1608} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 17981 17993 + ( ( $pad{I1609} = $pos or 1 ) && + + ## + ## pos: 17981 17984 + ( ( substr( $s, $pos, 1 ) eq '{' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1609} ) && 0 ) ) + ## + + && + ## + ## pos: 17993 18008 + ( + ( ( $pad{I1610} = $pos or 1 ) && + ## + ## pos: 17993 17998 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1610} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 18008 18019 + ( ( $pad{I1611} = $pos or 1 ) && + ## + ## pos: 18008 18014 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->rule( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'rule'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1611} ) && 0 ) ) + ## + + && + + ## + ## pos: 18019 18023 + ( ( $pad{I1612} = $pos or 1 ) && + + ## + ## pos: 18019 18022 + ( ( substr( $s, $pos, 1 ) eq '}' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1612} ) && 0 ) ) + ## + + && + ## + ## pos: 18023 18033 + ( + ( ( $pad{I1613} = $pos or 1 ) && + + ## + ## pos: 18023 18026 + ( ( substr( $s, $pos, 1 ) eq ';' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1613} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 18033 18145 + ( ( $pad{I1614} = $pos or 1 ) && + ## + ## pos: 18033 18144 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { + type => ${ $_[0]->[0] }, + name => ${ $_[0]->{qw(ident)} }, + ast => ${ $_[0]->{qw(rule)} } + }; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1614} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token verbatim +*verbatim = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 18207 18329 + ( + + ## + ## pos: 18207 18212 + ( ( $pad{I1615} = $pos or 1 ) && + + ## + ## pos: 18207 18211 + ( ( substr( $s, $pos, 2 ) eq '%{' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1615} ) && 0 ) ) + ## + + && + + ## + ## pos: 18212 18238 + ( ( $pad{I1616} = $pos or 1 ) && + + ## + do{ + my $hash = do { + my $bool = 1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + ## + ## pos: 18213 18236 + do { while ( + ( ( $pad{I1617} = $pos or 1 ) && + ## + ## pos: 18215 18233 + ( + + ## + ## pos: 18215 18231 + ( ( $pad{I1618} = $pos or 1 ) && + ## + ## pos: 18216 18230 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = + ## + ## pos: 18225 18229 + do{ + my $pos1 = $pos; + do { + my $pos = $pos1; + my $from = $pos; + my @match; + my %named; + $bool = 0 unless + + ## + ## pos: 18225 18229 + ( ( substr( $s, $pos, 2 ) eq '%}' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + ; + $bool; + }; + } + ## + ? 0 : 1; + $bool; + }; + } + ## + || ( ( $pos = $pad{I1618} ) && 0 ) ) + ## + + && + + ## + ## pos: 18231 18233 + ( ( $pad{I1619} = $pos or 1 ) && + + ## + ## pos: 18231 18232 + ( substr( $s, $pos++, 1 ) ne '' ) + ## + || ( ( $pos = $pad{I1619} ) && 0 ) ) + ## + + ) + ## + || ( ( $pos = $pad{I1617} ) && 0 ) )) {}; $bool = 1 } + ## + ; + { str => \$s, from => \$from, match => \@match, named => \%named, bool => \$bool, to => \(0+$pos), capture => undef } + }; + my $bool = ${$hash->{'bool'}}; + $match[ 0 ] = Pugs::Runtime::Match->new( $hash ); + $bool; + } + ## + || ( ( $pos = $pad{I1616} ) && 0 ) ) + ## + + && + + ## + ## pos: 18238 18247 + ( ( $pad{I1620} = $pos or 1 ) && + + ## + ## pos: 18238 18242 + ( ( substr( $s, $pos, 2 ) eq '%}' ) + ? ( $pos += 2 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1620} ) && 0 ) ) + ## + + && + + ## + ## pos: 18247 18329 + ( ( $pad{I1621} = $pos or 1 ) && + ## + ## pos: 18247 18328 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { + type => 'block', + value => ${ $_[0]->[0] } + }; + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1621} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token item +*item = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 18349 18441 + ( + ( $pad{I1622} = $pos or 1 ) + && ( + ## + ## pos: 18350 18397 + ( + + ## + ## pos: 18350 18368 + ( ( $pad{I1623} = $pos or 1 ) && + ## + ## pos: 18351 18361 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->verbatim( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'verbatim'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1623} ) && 0 ) ) + ## + + && + + ## + ## pos: 18368 18397 + ( ( $pad{I1624} = $pos or 1 ) && + ## + ## pos: 18368 18392 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return ${ $_[0]->{qw(verbatim)} }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1624} ) && 0 ) ) + ## + + ) + ## + + ) + || ( + ( ( $bool = 1 ) && ( $pos = $pad{I1622} ) or 1 ) + && ## + ## pos: 18398 18441 + ( + + ## + ## pos: 18398 18413 + ( ( $pad{I1625} = $pos or 1 ) && + ## + ## pos: 18399 18412 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->named_regex( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'named_regex'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1625} ) && 0 ) ) + ## + + && + + ## + ## pos: 18413 18441 + ( ( $pad{I1626} = $pos or 1 ) && + ## + ## pos: 18413 18440 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return ${ $_[0]->{qw(named_regex)} }; }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1626} ) && 0 ) ) + ## + + ) + ## + + ) + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token grammar +*grammar = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 18464 18580 + ( + ## + ## pos: 18464 18471 + ( + ( ( $pad{I1627} = $pos or 1 ) && + ## + ## pos: 18464 18469 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1627} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 18471 18481 + ( ( $pad{I1628} = $pos or 1 ) && + + ## + ## pos: 18471 18480 + ( ( substr( $s, $pos, 7 ) eq 'grammar' ) + ? ( $pos += 7 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1628} ) && 0 ) ) + ## + + && + + ## + ## pos: 18481 18487 + ( ( $pad{I1629} = $pos or 1 ) && + ## + ## pos: 18481 18486 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1629} ) && 0 ) ) + ## + + && + + ## + ## pos: 18487 18495 + ( ( $pad{I1630} = $pos or 1 ) && + ## + ## pos: 18487 18494 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ident( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { $named{'ident'} = $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1630} ) && 0 ) ) + ## + + && + ## + ## pos: 18495 18502 + ( + ( ( $pad{I1631} = $pos or 1 ) && + ## + ## pos: 18495 18500 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1631} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + + ## + ## pos: 18502 18510 + ( ( $pad{I1632} = $pos or 1 ) && + + ## + ## pos: 18502 18505 + ( ( substr( $s, $pos, 1 ) eq ';' ) + ? ( $pos += 1 or 1 ) + : 0 + ) + ## + || ( ( $pos = $pad{I1632} ) && 0 ) ) + ## + + && + ## + ## pos: 18510 18521 + ( + ( ( $pad{I1633} = $pos or 1 ) && + ## + ## pos: 18510 18515 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1633} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 18521 18544 + do { while ( + ( ( $pad{I1634} = $pos or 1 ) && + ## + ## pos: 18522 18537 + ( + + ## + ## pos: 18522 18530 + ( ( $pad{I1635} = $pos or 1 ) && + ## + ## pos: 18523 18529 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->item( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'item'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1635} ) && 0 ) ) + ## + + && + ## + ## pos: 18530 18537 + ( + ( ( $pad{I1636} = $pos or 1 ) && + ## + ## pos: 18530 18535 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->ws( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + my $bool = (!$match != 1); + $pos = $match->to if $bool; + $match; + } + ## + || ( ( $pos = $pad{I1636} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + ) + ## + || ( ( $pos = $pad{I1634} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 18544 18580 + ( ( $pad{I1637} = $pos or 1 ) && + ## + ## pos: 18544 18579 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { ${ $_[0]->{qw(ident)} } => $_[0]->{qw(item)} } }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1637} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + +# token spec +*spec = + ## + ## sigspace: 0 + ## ratchet: 1 + do { my $rule; $rule = sub { + my $grammar = $_[0]; + my $s = $_[1]; + $_[3] = $_[2] unless defined $_[3]; # backwards compat + no warnings 'substr', 'uninitialized', 'syntax'; + my %pad; + my $m; + my $bool; + my @pos; + # XXX :pos(X) takes the precedence over :continue ? + if (defined $_[3]{p}) { + push @pos, $_[3]{p} || 0; + } elsif ($_[3]{continue}) { + push @pos, (pos($_[1]) || 0) .. length($s); + } else { + push @pos, 0..length($s); + } + for my $pos ( @pos ) { + my %index; + my @match; + my %named; + $bool = 1; + $named{KEY} = $_[3]{KEY} if exists $_[3]{KEY}; + $m = Pugs::Runtime::Match->new( { + str => \$s, from => \(0+$pos), to => \($pos), + bool => \$bool, match => \@match, named => \%named, capture => undef, + } ); + { + my $prior = $::_V6_PRIOR_; + local $::_V6_PRIOR_ = $prior; + $bool = 0 unless + ## + ## pos: 18600 18720 + ( + ## + ## pos: 18600 18616 + ( + ( ( $pad{I1638} = $pos or 1 ) && + ## + ## pos: 18600 18610 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->verbatim( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'verbatim'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1638} ) && 0 ) ) + || ( $bool = 1 ) + ) + ## + + && + ## + ## pos: 18616 18631 + do { while ( + ( ( $pad{I1639} = $pos or 1 ) && + ## + ## pos: 18616 18625 + do { + my $prior = $::_V6_PRIOR_; + my $match = + $grammar->grammar( $s, { p => $pos, positionals => [ ], args => {}, }, undef ); + $::_V6_PRIOR_ = $prior; + if ( $match ) { push @{$named{'grammar'}}, $match; + $pos = $match->to; + 1 + } + else { 0 } + } + ## + || ( ( $pos = $pad{I1639} ) && 0 ) )) {}; $bool = 1 } + ## + + && + + ## + ## pos: 18631 18720 + ( ( $pad{I1640} = $pos or 1 ) && + ## + ## pos: 18631 18719 + do { + local $::_V6_SUCCEED = 1; + $::_V6_MATCH_ = $m; + $m->data->{capture} = \( sub { return { + block => $_[0]->{qw(verbatim)}, + 'grammar' => $_[0]->{qw(grammar)} } + }->( $m ) ); + $bool = $::_V6_SUCCEED; + $::_V6_MATCH_ = $m if $bool; + return $m if $bool; + } + ## + || ( ( $pos = $pad{I1640} ) && 0 ) ) + ## + + ) + ## + ; + } + if ( $bool ) { + my $prior = $::_V6_PRIOR_; + $::_V6_PRIOR_ = sub { + local $main::_V6_PRIOR_ = $prior; + $rule->(@_); + }; + #warn "pos2 = ", $pos, "\n"; + pos($_[1]) = $pos if $_[3]{continue}; + last; + } + } # /for + $::_V6_MATCH_ = $m; + return $m; + } } + ## +; + + + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Grammar/Rule2.pm b/blib6/pugs/perl5/lib/Pugs/Grammar/Rule2.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Grammar/Rule2.pm @@ -0,0 +1,608 @@ +# WARNING: This file is no longer used by PCR itself; +# we're using examples/Grammar.grammar to generate Pugs::Grammar::Rule.pmc +# instead. + +use v6-alpha; +use utf8; + +# Perl6 implementation of the 'Rule' syntax +# author: Flavio S. Glock - fglock@gmail.com + +=for compiling + + The util/update-rule-pmc script is used to + generate lib/Pugs/Grammar/Rule.pmc from + this file. + + This script does the following: + + Use v6.pm to compile this file and + post-process it after compiling: + - remove all references to: + Data::Bind + - replace the header with: + package Pugs::Grammar::Rule; + use utf8; + no strict 'refs'; + use Pugs::Runtime::Match; + use Pugs::Runtime::Regex; + The post-processing thing is done + by the Perl 5 script util/patch-rule-pmc.pl + +=cut + +grammar Pugs::Grammar::Rule; + +#use Pugs::Runtime::Match; + +our %rule_terms; +our %variables; + +token pod_begin { + | \n =end \N* + | . \N* <.pod_begin> +} + +token pod_other { + | \n =cut \N* + | . \N* <.pod_other> +} + +token ws { + [ + | \# \N* + | \n [ = [ + | begin <.ws> END \N* .* + | begin <.pod_begin> + | kwid <.pod_other> + | pod <.pod_other> + | for <.pod_other> + | head1 <.pod_other> + ]? + ]? + | \s + ]+ +} + +# regex ident can start with a number +token ident { + [ <.alnum> | _ | '::' ]+ +} + +token alnum { + <[0-9a-zA-Z]> +} + +token alpha { + <[a-zA-Z]> +} + +token digit { + <[0-9]> +} + +# after '\\' +token special_char { + | ( c | C ) \[ ( [|\s| ';' | '(' | ')' | '-' ]+) \] + # \c[LATIN LETTER A] + { return { special_char => '\\' ~ $0 ~ $1 , } } + + | [ x | X ] + + # \x0021 \X0021 + { return { special_char => '\\' ~ $/ , } } + | ( x | X ) \[ (+) \] + # \x[0021] \X[0021] + { return { special_char => '\\' ~ $0 ~ $1 , } } + + | [ o | O ] \d+ + # \o0021 \O0021 + { return { special_char => '\\' ~ $/ , } } + | ( o | O ) \[ (\d+) \] + # \o[0021] \O[0021] + { return { special_char => '\\' ~ $0 ~ $1 , } } + + | . + # \e \E + { return { special_char => '\\' ~ $/ , } } +} + +token literal { + [ + | \\ + | <-[ \' ]> + ]* +} + +token double_quoted { + [ + | \\ + | <%Pugs::Grammar::Rule::variables> + | <-[ \" ]> + ]* +} + +token metasyntax { + [ + | \\ + | \' <.literal> \' + | \" <.double_quoted> \" + | \{ <.string_code> \} + | \< <.metasyntax> \> + | <-[ \> ]> + ]+ +} + +token char_range { + [ + | \\ + | <-[ \] ]> + ]+ +} + +token char_class { + | <.alpha>+ + | \[ <.char_range> \] +} + +token string_code { + # bootstrap "code" + [ + | \\ + | \' <.literal> \' + | \" <.double_quoted> \" + | \{ [ <.string_code> | '' ] \} + | \( [ <.string_code> | '' ] \) + | \< [ <.string_code> | '' ] \> + | [ <.ws> | \> | \= | \- ] \> + | <.ws> + | <-[ \} \) \> ]> + ]+ +} + +token parsed_code { + # this subrule is overridden inside the perl6 compiler + <.string_code> + { return '{' ~ $/ ~ '}' } +} + +token named_capture_body { + | \( \) { return { capturing_group => $$ ,} } + | \[ \] { return $$ } + | \< { return $$ } + | \' <.literal> \' + { return { metasyntax => { metasyntax => ~ $$/ ,} } } + | { die "invalid alias syntax"; } +} + +token parse_metasyntax { + $ := [ '!' | '?' | '.' | '' ] + [ + '{' '}>' + { return { closure => { + closure => $$, + modifier => $$, + } } } + | + + ( <[+-]> )+ + \> + { + if ( $$ eq '!' ) { + return { + negate => { + char_class => [ + '+' ~ $, + @($/[0]), # TODO - stringify + ] } } + } + return { + char_class => [ + '+' ~ $, + @($/[0]), # TODO - stringify + ] } + } + | + + [ + <.ws> \> + { + if ( $$ eq 'before' + || $$ eq 'after' + ) { + return { $$ => { rule => $$, modifier => $$ } } + } + return { metasyntax => { + metasyntax => $$, + rule => $$, + modifier => $$, + } } + } + | + ':' <.ws>? + $ := [ + [ + | \\ + | <%Pugs::Grammar::Rule::variables> + | <-[ \> ]> + ]* + ] + \> + { + if ( $$ eq 'before' + || $$ eq 'after' + ) { + return { $$ => { + rule => { metasyntax => { + metasyntax => '\'' ~ $$ ~ '\'' + } }, + modifier => $$, + } } + } + return { metasyntax => { + metasyntax => $$, + string => $$, + modifier => $$, + } } + } + | + \( \) \> + { return { call => { + method => $$, + params => $$, + modifier => $$, + } } } + ] + | + \> + { return { metasyntax => { + metasyntax => ~$$, + modifier => $$, + } } } + ] +} + + +%variables = ( + + '$<' => token { + \> + { return { match_variable => '$' ~ $/ ,} } + }, + '$' => token { + <.digit>+ + { return { match_variable => '$' ~ $/ ,} } + | + \^? + [ <.alnum> | _ | \: \: ]+ + { return { variable => '$' ~ $/ ,} } + }, + '@' => token { + <.digit>+ + { return { match_variable => '@' ~ $/ ,} } + | + \^? + [ <.alnum> | _ | \: \: ]+ + { return { variable => '@' ~ $/ ,} } + }, + '%' => token { + <.digit>+ + { return { match_variable => '%' ~ $/ ,} } + | + \^? + [ <.alnum> | _ | \: \: ]+ + { return { variable => '%' ~ $/ ,} } + }, + +); # /%variables + + +%rule_terms = ( + + '{*}' => token { + # placeholder + { return { metasyntax => { metasyntax => 'null' ,} } } + }, + + '\'' => token { + <.literal> \' + { return { metasyntax => { metasyntax => '\'' ~ $$/ ,} } } + }, + '(' => token { + \) + { return { capturing_group => $$ ,} } + }, + '<(' => token { + ')>' + { return { capture_as_result => $$ ,} } + }, + '<+' => token { + + ( <[+-]> )* + \> + { return { + char_class => [ + '+' ~ $, + @($/[0]), # TODO - stringify + ] } + } + }, + '<-' => token { + + ( <[+-]> )* + \> + { return { + char_class => [ + '-' ~ $, + @($/[0]), # TODO - stringify + ] } + } + }, + '<[' => token { + \] + ( <[+-]> )* + \> + { return { + char_class => [ + '+[' ~ $ ~ ']', + @($/[0]), # TODO - stringify + ] } + } + }, + '<' => token { + + { return $$ } + }, + '{' => token { + \} + { return { closure => { + closure => $$, + modifier => 'plain', + } } } + }, + '\\' => token { + + { return $$ } + }, + '.' => token { + { return { 'dot' => 1 ,} } + }, + '[' => token { + \] + { return $$ } + }, + ':::' => token { { return { colon => ':::' ,} } }, + ':?' => token { { return { colon => ':?' ,} } }, + ':+' => token { { return { colon => ':+' ,} } }, + '::' => token { { return { colon => '::' ,} } }, + ':' => token { { return { colon => ':' ,} } }, + '$$' => token { { return { colon => '$$' ,} } }, + '$' => token { { return { colon => '$' ,} } }, + '^^' => token { { return { colon => '^^' ,} } }, + '^' => token { { return { colon => '^' ,} } }, + + '>>' => token { { return { colon => '>>' ,} } }, + '»' => token { { return { colon => '>>' ,} } }, + + '<<' => token { { return { colon => '<<' ,} } }, + '«' => token { { return { colon => '<<' ,} } }, + + ':i' => token { + <.ws> + { return { modifier => { modifier => 'ignorecase', :$$, } } } }, + ':ignorecase' => token { + <.ws> + { return { modifier => { modifier => 'ignorecase', :$$, } } } }, + ':s' => token { + <.ws> + { return { modifier => 'sigspace', :$$, } } }, + ':sigspace' => token { + <.ws> + { return { modifier => 'sigspace', :$$, } } }, + ':P5' => token { + <.ws> + { return { modifier => 'Perl5', :$$, } } }, + ':Perl5' => token { + <.ws> + { return { modifier => 'Perl5', :$$, } } }, + ':bytes' => token { + <.ws> + { return { modifier => 'bytes', :$$, } } }, + ':codes' => token { + <.ws> + { return { modifier => 'codes', :$$, } } }, + ':graphs' => token { + <.ws> + { return { modifier => 'graphs', :$$, } } }, + ':langs' => token { + <.ws> + { return { modifier => 'langs', :$$, } } }, + +); # /%rule_terms + +token term { + | <%Pugs::Grammar::Rule::variables> + [ <.ws>? ':=' <.ws>? + { + return { named_capture => { + rule => $$, + ident => $$, + }, }; + } + | + { + return $$ + } + ] + | <%Pugs::Grammar::Rule::rule_terms> + { + #print "term: ", Dumper( $_[0]->data ); + return $$ + } + | <-[ \] \} \) \> \: \? \+ \* \| \& ]> + { + #print "constant: ", Dumper( $_[0]->data ); + return { 'constant' => $$/ ,} + } +} + +token quant { + | '**' <.ws>? \{ \} + { return { closure => $$ ,} } + | <[ \? \* \+ ]>? +} + +token quantifier { + $ := (<.ws>?) + > + + $ := (<.ws>?) + + $ := (<[ \? \+ ]>?) + $ := (<.ws>?) + { + if + $$/{'quant'} eq '' + && $$/{'greedy'} eq '' + && $$/{'ws1'} eq '' + && $$/{'ws2'} eq '' + && $$/{'ws3'} eq '' + { + return $$/{'term'}; + } + return { + quant => { + term => $$/{'term'}, + quant => $$/{'quant'}, + greedy => $$/{'greedy'}, + ws1 => $$/{'ws1'}, + ws2 => $$/{'ws2'}, + ws3 => $$/{'ws3'}, + } } + } +} + +token concat { + + + { + use v5; + my @a = map { $_->() } @{ $::_V6_MATCH_->{'quantifier'} }; + return { concat => \@a ,} if scalar @a > 1; + return $a[0]; + use v6; + } +} + +token conjunctive1 { + [ <.ws>? \& ]? + + **{1} + [ + \& + ]* + + { + use v5; + my @a = map { $$_ } @{ $::_V6_MATCH_->{'concat'} }; + return { conjunctive1 => \@a ,} if scalar @a > 1; + return $a[0]; + use v6; + } +} + +token disjunctive1 { + [ <.ws>? \| ]? + + **{1} + [ + \| + ]* + + { + use v5; + my @a = map { $$_ } @{ $::_V6_MATCH_->{'conjunctive1'} }; + return { alt1 => \@a ,} if scalar @a > 1; + return $a[0]; + use v6; + } +} + +token conjunctive { + [ <.ws>? \& \& ]? + + **{1} + [ + \& \& + ]* + + { + use v5; + my @a = map { $$_ } @{ $::_V6_MATCH_->{'disjunctive1'} }; + return { conjunctive => \@a ,} if scalar @a > 1; + return $a[0]; + use v6; + } +} + +token rule { + [ <.ws>? \| \| ]? + + **{1} + [ + \| \| + ]* + + { + use v5; + my @a = map { $$_ } @{ $::_V6_MATCH_->{'conjunctive'} }; + return { alt => \@a ,} if scalar @a > 1; + return $a[0]; + use v6; + } +} + +token named_regex { + ( 'token' | 'regex' | 'rule' ) + <.ws> <.ws>? '{' + <.ws>? + + '}' ';'? + + { return { + type => $$0, + name => $$, + ast => $$ + }; + } +} + +# This is hacky, will do better later +token verbatim { + '%{' ( [ . ]* ) '%}' + { return { + type => 'block', + value => $$0 + }; + } +} + +token item { + | { return $$; } + | { return $$; } +} + +token grammar { + <.ws>? 'grammar' <.ws> <.ws>? ';' + <.ws>? + [ <.ws>? ]* + { return { $$ => $ } } +} + +token spec { + ? + * + { return { + block => $, + 'grammar' => $ } + } +} + diff --git a/blib6/pugs/perl5/lib/Pugs/Grammar/RulePure.pm b/blib6/pugs/perl5/lib/Pugs/Grammar/RulePure.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Grammar/RulePure.pm @@ -0,0 +1,263 @@ + +use v6-alpha; + +# Pure-Perl6 implementation of the 'Rule' syntax +# author: Flavio S. Glock - fglock@gmail.com + +# This is for demonstation only, it currently can't be run by +# Pugs::Compiler::Rule runtime + +grammar Pugs::Grammar::Rule; + +our %rule_terms; +our %variables; + +token pod_begin { + | \n =end \N* + | . \N* +} + +token pod_other { + | \n =cut \N* + | . \N* +} + +token ws { + [ + | \# \N* + | \n [ = [ + | begin END \N* .* + | begin + | kwid + | pod + | for + | head1 + ]? + ]? + | \s + ]+ +} + +# regex ident can start with a number +token ident { + [ | _ | <'::'> ]+ +} + +token literal { + [ + | \\ . + | <-[ \' ]> + ]* +} + +token metasyntax { + [ + | \\ . + | \' \' + | \{ \} + | \< \> + | <-[ \> ]> + ]+ + { return { metasyntax => $$/ ,} } +} + +token string_code { + # bootstrap "code" + [ + | \\ . + | \' \' + | \{ \} + | <-[ \} ]> + ]+ +} + +token parsed_code { + # this subrule is overridden inside the perl6 compiler + + { return '{' ~ $/ ~ '}' } +} + +token named_capture_body { + | \( \) { return { capturing_group => $$ ,} } + | \[ \] { return $$ } + | \< \> { return $$ } + | { die "invalid alias syntax" } +} + +%variables = ( + + '$<' => token { + \> + { return { match_variable => '$' ~ $/ ,} } + }, + '$' => token { + + + { return { match_variable => '$' ~ $/ ,} } + | + \^? + [ | _ | \: \: ]+ + { return { variable => '$' ~ $/ ,} } + }, + '@' => token { + + + { return { match_variable => '@' ~ $/ ,} } + | + \^? + [ | _ | \: \: ]+ + { return { variable => '@' ~ $/ ,} } + }, + '%' => token { + + + { return { match_variable => '%' ~ $/ ,} } + | + \^? + [ | _ | \: \: ]+ + { return { variable => '%' ~ $/ ,} } + }, + +); # /%variables + + +%rule_terms = ( + + '(' => token { + \) + { return { capturing_group => $$ ,} } + }, + '<(' => token { + <')>'> + { return { capture_as_result => $$ ,} } + }, + ' token { + \> + { return { after => :$$, } } + }, + ' token { + \> + { return { before => :$$, } } + }, + ' token { + \> + { return { not_before => :$$, } } + }, + ' token { + \> + { return { negate => :$$, } } + }, + '<' => token { + \> + { return $$ } + }, + '{' => token { + \} + { return { closure => $$ ,} } + }, + '\\' => token { + . + { return { special_char => '\\' ~ $/ , } } + }, + '.' => token { + { return { 'dot' => 1 ,} } + }, + '[' => token { + \] + { return $$ } + }, + ':::' => token { { return { colon => ':::' ,} } }, + ':?' => token { { return { colon => ':?' ,} } }, + ':+' => token { { return { colon => ':+' ,} } }, + '::' => token { { return { colon => '::' ,} } }, + ':' => token { { return { colon => ':' ,} } }, + '$$' => token { { return { colon => '$$' ,} } }, + '$' => token { { return { colon => '$' ,} } }, + '^^' => token { { return { colon => '^^' ,} } }, + '^' => token { { return { colon => '^' ,} } }, + + ':i' => token { { return { modifier => 'ignorecase' ,} } }, + ':ignorecase' => token { { return { modifier => 'ignorecase' ,} } }, + ':s' => token { { return { modifier => 'sigspace' ,} } }, + ':sigspace' => token { { return { modifier => 'sigspace' ,} } }, + ':P5' => token { { return { modifier => 'Perl5' ,} } }, + ':Perl5' => token { { return { modifier => 'Perl5' ,} } }, + ':bytes' => token { { return { modifier => 'bytes' ,} } }, + ':codes' => token { { return { modifier => 'codes' ,} } }, + ':graphs' => token { { return { modifier => 'graphs' ,} } }, + ':langs' => token { { return { modifier => 'langs' ,} } }, + +); # /%rule_terms + +token term { + | <%Pugs::Grammar::Rule::variables> + [ ? <':='> ? + { + return { named_capture => { + rule => $$, + ident => $$, + }, }; + } + | + { + return $$ + } + ] + | <%Pugs::Grammar::Rule::rule_terms> + { + #print "term: ", Dumper( $_[0]->data ); + return $$ + } + | <-[ \] \} \) \> \: \? \+ \* \| \& ]> + { + #print "constant: ", Dumper( $_[0]->data ); + return { 'constant' => $$/ ,} + } +} + +token quant { + | <'**'> ? \{ \} + { return { closure => $$ ,} } + | <[ \? \* \+ ]>? +} + +token quantifier { + $ := (?) + ]> > + + $ := (?) + + $ := (<[ \? \+ ]>?) + $ := (?) + { return { + quant => { + term => $$/{'term'}, + quant => $$/{'quant'}, + greedy => $$/{'greedy'}, + ws1 => $$/{'ws1'}, + ws2 => $$/{'ws2'}, + ws3 => $$/{'ws3'}, + } } + } +} + +token concat { + + + { + my $a = $.map( { $$_ } ); + return { concat => $a ,} if $a.elems > 1; + return $a[0]; + } +} + +token rule { + [ ? \| ]? + + + [ + \| + ]* + + { + my $a = $.map( { $$_ } ); + return { alt => $a ,} if $a.elems > 1; + return $a[0]; + } +} diff --git a/blib6/pugs/perl5/lib/Pugs/Runtime/Common.pm b/blib6/pugs/perl5/lib/Pugs/Runtime/Common.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Runtime/Common.pm @@ -0,0 +1,62 @@ + +package Pugs::Runtime::Common; + +use strict; +use warnings; + +our %quote = ( + # left => # right + "'" => "'", + '"' => '"', + '/' => '/', + '!' => '!', + '(' => ')', + '[' => ']', + '{' => '}', + '<' => '>', + '<<' => '>>', + '«' => '»', + '“' => '”', + '‘' => '’', +); + +our %perl6_name = ( + # perl 5 => # perl 6 + '%::ENV' => '%*ENV', + '$^O' => '$*OS', + '$$' => '$*PID', + '$0' => '$*EXECUTABLE_NAME', + '$0' => '$*PROGRAM_NAME', + '@INC' => '@*INC', + + '\\*STDERR' => '$*ERR', + + '__FILE__' => '$?FILE', + + '$::_V6_ERR_' => '$!', + '$::_V6_MATCH_' => '$/', + '$::_V6_STDIN' => '$*IN', + '$::_V6_STDOUT' => '$*OUT', + '$::_V6_BACKEND'=> '$?PUGS_BACKEND', + '$::_V6_COMPILER_OS' => '$?OS', + '$::_V6_COMPILER_NAME' => '$?COMPILER', + '$::_V6_COMPILER_VERSION' => '$?VERSION', +); +our %perl5_name = reverse %perl6_name; + +sub mangle_ident { + my $s = shift; + Carp::confess unless defined $s; + $s =~ s/ ([^a-zA-Z0-9_:] | (? \&array, + '%{}' => \&hash, + 'bool' => \&bool, + '&{}' => \&code, + '${}' => \&scalar, + '""' => \&flat, + '0+' => \&flat, + fallback => 1, +); + +# class method +# ::fail can be called from inside closures +# sub ::fail { $::_V6_SUCCEED = 0 } + +my %_data; + +sub new { + my $obj = bless \$_[1], $_[0]; + $_data{ refaddr $obj } = $_[1]; + return $obj; +} + +sub DESTROY { + delete $_data{ refaddr $_[0] }; +} + +sub data { $_data{refaddr $_[0]} } +sub bool { ${$_data{refaddr $_[0]}->{bool}} } +sub array { $_data{refaddr $_[0]}->{match} } + +sub from { + + return ${$_data{refaddr $_[0]}->{from}}; + + my $obj = $_data{refaddr $_[0]}; + #return ${$obj->{from}} if blessed ${$obj->{from}}; + Pugs::Runtime::StrPos->from_str_codes( ${$obj->{str}}, ${$obj->{from}} ); +} +sub pos { $_[0]->to } # pugs pos.t - lvalue ??? +sub to { + + return ${$_data{refaddr $_[0]}->{to}}; + + my $obj = $_data{refaddr $_[0]}; + #return ${$obj->{to}} if blessed ${$obj->{to}}; + #print "TO: ",${$obj->{to}},"\n"; + Pugs::Runtime::StrPos->from_str_codes( ${$obj->{str}}, ${$obj->{to}} ); +} +# "low-level" position defaults to perl5-utf8 +sub from_as_codes { ${$_data{refaddr $_[0]}->{from}} } +sub to_as_codes { ${$_data{refaddr $_[0]}->{to}} } + +sub hash { + my $array = $_data{refaddr $_[0]}->{match}; + my $hash = $_data{refaddr $_[0]}->{named}; + $hash->{$_} = $array->[$_] for 0 .. $#$array; + return $hash; + + #my $array = $_data{refaddr $_[0]}->{match}; + #return { + # %{ $_data{refaddr $_[0]}->{named} }, + # ( + # map { ( $_, $array->[$_] ) } + # 0 .. $#$array + # ), + #} +} +sub keys { + CORE::keys %{$_data{refaddr $_[0]}->{named}}, + 0 .. $#{ $_[0]->array } +} +sub values { + CORE::values %{$_data{refaddr $_[0]}->{named}}, + @{ $_[0]->array } +} +sub kv { + map { ( $_, $_[0]->{$_} ) } + $_[0]->keys +} +sub elems { + scalar $_[0]->keys +} + +sub chars { CORE::length $_[0]->str } + +sub flat { + my $obj = $_data{refaddr $_[0]}; + my $cap = $obj->{capture}; + #print ref $cap; + return $$cap + if ref $cap eq 'REF' || + ref $cap eq 'SCALAR'; + return '' unless ${$obj->{bool}}; + + return '' if $_[0]->from > length( ${$obj->{str}} ); + + return substr( ${$obj->{str}}, $_[0]->from, $_[0]->to - $_[0]->from ); +} + +sub str { + "" . $_[0]->flat; +} + +sub perl { + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Pad = ' '; + return __PACKAGE__ . "->new( " . Dumper( $_[0]->data ) . ")\n"; +} + +sub yaml { + require YAML::Syck; + # interoperability with other YAML/Syck bindings: + $YAML::Syck::ImplicitTyping = 1; + YAML::Syck::Dump( $_[0] ); +} + +# for Pugs interoperability +sub dump_hs { + my $obj; + if (ref($_[0]) eq 'SCALAR') { + $obj = ${$_[0]}; + } + else { + $obj = $_data{refaddr $_[0]}; + } + + if ($obj) { + # Ok, this is a genuine Match object. + return "PGE_Fail" unless ${$obj->{bool}}; + + # Now we matched; dump the rest of data + join(' ', 'PGE_Match', ${$obj->{from}}, ${$obj->{to}}, + ('['.join(', ', map { dump_hs($_) } @{$obj->{match}||[]} ).']'), + ('['.join(', ', map { + my $str = $_; + if ( my $dump = dump_hs($obj->{named}{$_}) ) { + $str =~ s/([^ \!\#\$\%\&\x28-\x5B\x5D-\x7E])/'\\'.ord($1)/eg; + qq[("$str", $dump)]; + } + else { + (); + } + } sort(CORE::keys(%{$obj->{named}||{}})) ).']'), + ) + } + elsif (ref($_[0]) eq 'ARRAY') { + return "PGE_Array [" . join(', ', map { dump_hs($_) } @$obj) . "]" + } + elsif (!ref($_[0])) { + my $str = shift; + $str =~ s/([^ \!\#\$\%\&\x28-\x5B\x5D-\x7E])/'\\'.ord($1)/eg; + return "PGE_String \"$str\""; + } + else { + warn "Unrecognized blessed match object: $_[0]"; + return ''; + } +} + +# tail() for backwards compatibility +# - doesn't work on failed matches +sub tail { + return substr( ${$_data{refaddr $_[0]}->{str}}, $_[0]->to ); +} + +# state() is used for multiple matches and backtracking control +sub state { + return $_data{refaddr $_[0]}->{state}; +} + +# return the capture +sub code { + my $c = $_[0]; + return sub { $c->flat }; +} + +# return the capture +sub scalar { + return \( $_[0]->flat ); +} + +1; + +__END__ + +=head1 NAME + +Pugs::Runtime::Match - Match object created by rules + +=head1 METHODS + +* array + +- return the positional matches + +* hash + +- return both the named and positional (numbered) matches + +* str + +- return the stringified capture object. +If there is no capture, return the matched substring + +* scalar + +- return the capture object +If there is no capture, return the matched substring + +* bool + +- return whether there was a match + +* from + +- return the string position (a C object) where the match started. + +* to + +- return the string position (a C object) immediately after where the match finished. + +* from_as_codes +* to_as_codes + +- same as C/C methods, but return perl5 integers. + +=head1 "Hash" methods + +* elems + +* kv + +* keys + +* values + +=head1 "Str" methods + +* chars + +=head1 OVERLOADS + +* $$match + +- return the capture object + +* $match->[$n] + +- return the positional matches + +* $match->{$n} + +- return the named matches + +* $match ? 1 : 0 + +- return whether there was a match + +=head1 Dumper methods + +* data + +- return the internal representation as a data structure. + +* perl + +- return the internal representation as Perl source code. + +* yaml + +- return the internal representation as YAML. +Requires the C module. + +* dump_hs + +- for Pugs interoperability + +=head1 SEE ALSO + +C on CPAN + +=head1 AUTHORS + +The Pugs Team Eperl6-compiler@perl.orgE. + +=head1 COPYRIGHT + +Copyright 2006 by Flavio Soibelmann Glock and others. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut + diff --git a/blib6/pugs/perl5/lib/Pugs/Runtime/Match/HsBridge.pm b/blib6/pugs/perl5/lib/Pugs/Runtime/Match/HsBridge.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Runtime/Match/HsBridge.pm @@ -0,0 +1,83 @@ +package Pugs::Runtime::Match::HsBridge; + +use utf8; +use strict; +use warnings; +use Pugs::Grammar::Base (); +use Pugs::Compiler::Regex (); +use base 'Pugs::Grammar::Base'; + +BEGIN { local $@; eval { require 'utf8_heavy.pl' } } + +use ops ($ENV{PUGS_SAFEMODE} ? (':default', 'binmode', 'entereval') : ()); + +sub __RUN__ { + my $self = shift; + my $match_text = shift; + my $rule_text = shift; + my %subrules = @_; + + while (my ($name, $body) = each %subrules) { + my %sub_opts = (grammar => __PACKAGE__); + ($1 and $sub_opts{$1} = 1) while $body =~ s/^:(\w*)\(1?\)\[(.*)\]\z/$2/s; + Pugs::Compiler::Regex->reinstall( $name => $body, \%sub_opts ); + } + + my %opts = (grammar => __PACKAGE__); + ($1 and $opts{$1} = 1) while $rule_text =~ s/^:(\w*)\(1?\)\[(.*)\]\z/$2/s; + + # L modifier also implies that the anchoring"> + if ( $opts{ratchet} ) { + $rule_text = "^$rule_text" unless $opts{p} or $opts{pos}; + $rule_text .= '$' unless $opts{c} or $opts{continue}; + } + + local $SIG{__WARN__} = sub { 1 }; + + my $rule = Pugs::Compiler::Regex->compile( $rule_text, \%opts ); + my $match = $rule->match( $match_text ); + + return $match->dump_hs; +} + +sub __CMD__ { + local $| = 1; + + # Command line shell interface - compatible with run_pge.pir + if ($] >= 5.007) { + binmode STDIN, ':utf8'; + binmode STDOUT, ':utf8'; + } + + my @subrules; + while () { + #/^(\w+) (\d+) (\d+)/ or die "Unrecognized command: $_"; + /^(\w+) \d+ \d+/ or die "Unrecognized command: $_"; + my $cmd = $1; # my ($cmd, $sz1, $sz2) = ($1, $2, $3); + + my $line1 = ; chomp($line1); $line1 =~ s{\\(?:(\\)|(n))}{$1 ? $1 : "\n"}eg; + my $line2 = ; chomp($line2); $line2 =~ s{\\(?:(\\)|(n))}{$1 ? $1 : "\n"}eg; + + if ($cmd eq 'add_rule') { + push @subrules, $line1, $line2; + } + elsif ($cmd eq 'match') { + if (my $rv = eval { __PACKAGE__->__RUN__($line1, $line2, @subrules) }) { + my $len = bytes::length($rv)+1; + print "OK $len\n"; + print "$rv\n\n"; + } + else { + my $err = $@; + $err =~ s/([\\\n])/\\$1/g; + print "$err\n"; + } + @subrules = (); + } + else { + die "Unrecognized command: $cmd"; + } + } +} + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Runtime/Regex.pm b/blib6/pugs/perl5/lib/Pugs/Runtime/Regex.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Runtime/Regex.pm @@ -0,0 +1,822 @@ +package Pugs::Runtime::Regex; + +# documentation after __END__ + +use strict; +use warnings; +no warnings qw(recursion); + +#use Smart::Comments; #for debugging, look also at Filtered-Comments.pm +use Data::Dumper; +use Pugs::Runtime::Match; +use Carp qw(croak); + +# note: alternation is first match (not longest). +# note: the list in @$nodes can be modified at runtime +sub alternation { + my $nodes = shift; + return sub { + my @state = $_[1] ? @{$_[1]} : ( 0, undef ); + while ( $state[0] <= $#$nodes ) { + #print "alternation $state[0] ",Dumper($nodes->[ $state[0] ]); + $nodes->[ $state[0] ]->( $_[0], $state[1], @_[2..7] ); + last unless defined $_[3]; # test case ??? + $state[1] = $_[3]->state; + $state[0]++ unless $state[1]; + if ( $_[3] || $_[3]->data->{abort} ) { + $_[3]->data->{state} = $state[0] > $#$nodes + ? undef + : \@state; + return; + } + } + $_[3] = failed()->(@_); + } +} + +sub concat { + my $nodes = shift; + $nodes = [ $nodes, @_ ] unless ref($nodes) eq 'ARRAY'; # backwards compat + return null() if ! @$nodes; + return $nodes->[0] if @$nodes == 1; + if ( @$nodes > 2 ) { + return concat( + concat( [ $nodes->[0], $nodes->[1] ] ), + @$nodes[ 2 .. $#$nodes ], + ); + } + return sub { + my @state = $_[1] ? @{$_[1]} : ( undef, undef ); + #print "enter state ",Dumper(\@state); + my $m2; + my $redo_count = 0; + # XXX - workaround for t/regex/from_perl6_rules/capture.t test #38: + # regex single { o | k | e }; + # # ... + # ok(!( "bokeper" ~~ m/() ($0)/ ), 'Failed positional backref'); + + do { + + my %param1 = defined $_[7] ? %{$_[7]} : (); + #print "concat 1: @{[ %param1 ]} \n"; + + $nodes->[0]->( $_[0], $state[0], @_[2..7] ); + return if ! $_[3] + || $_[3]->data->{abort}; + + my $is_empty = ( $_[3]->from == $_[3]->to ); + # && ( $param1{was_empty} ) + # ; # fix a problem with '^' + if ( $is_empty && $param1{was_empty} ) { + # # perl5 perlre says "the following match after a zero-length match + # is prohibited to have a length of zero" + return unless $_[3]->from == 0; + } + + my $param = { ( defined $_[7] ? %{$_[7]} : () ), + p => $_[3]->to, + was_empty => $is_empty, + }; + # TODO - retry the second submatch only, until it fails + my $next_state = $_[3]->state; + #print "next_state ",Dumper($next_state); + #print "concat 2: "," \n"; + $nodes->[1]->( $_[0], $state[1], $_[2], $m2, + $_[4], $_[3]->to, $_[6], $param ); + + #return if $is_empty && $m2->from == $m2->to; + $state[1] = $m2->state; + $state[0] = $next_state unless $state[1]; + #print "concat 3: "," \n"; + #print "return state ",Dumper(\@state); + + } while ! $m2 + && ! $m2->data->{abort} + && defined $state[0] + && $redo_count++ < 512 + ; + + # push capture data + # print "Concat positional: ", Dumper( $_[3]->data->{match}, $m2->data->{match} ); + for ( 0 .. $#{ $m2 } ) { + if ( ref $m2->[$_] eq 'ARRAY' ) { + # TODO - fully static count + # push @{ $_[3]->data->{match}[$_] }, @{ $m2->[$_] }; + $_[3]->data->{match}[$_] = [ + ( ref( $_[3]->data->{match}[$_] ) eq 'ARRAY' + ? @{ $_[3]->data->{match}[$_] } + : defined( $_[3]->data->{match}[$_] ) + ? $_[3]->data->{match}[$_] + : () + ), + @{ $m2->[$_] }, + ]; + } + elsif ( defined $m2->[$_] ) { + $_[3]->data->{match}[$_] = $m2->[$_]; + } + } + #print "Concat named: ", Dumper( $_[3]->data->{named}, $m2->data->{named} ); + for ( keys %{$m2} ) { + if ( ref $m2->{$_} eq 'ARRAY' ) { + # TODO - fully static count + #push @{ $_[3]->data->{named}{$_} }, @{ $m2->{$_} }; + $_[3]->data->{named}{$_} = [ + ( ref( $_[3]->data->{named}{$_} ) eq 'ARRAY' + ? @{ $_[3]->data->{named}{$_} } + : defined( $_[3]->data->{named}{$_} ) + ? $_[3]->data->{named}{$_} + : () + ), + @{ $m2->{$_} }, + ]; + } + elsif ( defined $m2->{$_} ) { + $_[3]->data->{named}{$_} = $m2->{$_}; + } + } + # /push capture data + + %{$_[3]->data} = ( + %{$_[3]->data}, + bool => \($m2->bool), + to => \($m2->to), + capture => $m2->data->{capture} || $_[3]->data->{capture}, + abort => $m2->data->{abort}, + state => ( defined $state[0] || defined $state[1] + ? \@state + : undef ), + ); + } +} + +sub try_method { + my $method = shift; + my $param_list = shift; # XXX + no warnings qw( uninitialized ); + # XXX method call must be inlined, due to inheritance problems + my $sub = 'sub { + my $bool = $_[0]->'.$method.'( '.$param_list.' ) ? 1 : 0; + $_[3] = Pugs::Runtime::Match->new({ + bool => \$bool, + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + }); + }'; + #print "sub: $sub\n"; + return eval $sub; +} + + +sub ignorecase { + my $sub = shift; + no warnings qw( uninitialized ); + return sub { + my %param = ( ( defined $_[7] ? %{$_[7]} : () ), ignorecase => 1 ); + $sub->( @_[0..6], \%param ); + } +} + +sub constant { + my $const = shift; + my $lconst = length( $const ); + no warnings qw( uninitialized ); + return sub { + my $bool = $_[7]{ignorecase} + ? lc( $const ) eq lc( substr( $_[0], $_[5], $lconst ) ) + : $const eq substr( $_[0], $_[5], $lconst ); + $_[3] = Pugs::Runtime::Match->new({ + bool => \$bool, + str => \$_[0], + from => \(0 + $_[5]), + to => \($_[5] + $lconst), + named => {}, + match => [], + }); + } +} + +sub perl5 { + my $rx; + no warnings qw( uninitialized ); + { + local $@; + $rx = eval " use charnames ':full'; qr(^($_[0]))s "; + #print "regex perl5<< $_[0] >>\n"; + print "Error in perl5 regex: << $_[0] >> \n$@\n" + if $@; + #die "Error in perl5 regex: $_[0]" + # if $@; + } + return sub { + #use charnames ':full'; + my $bool = $_[7]{ignorecase} + ? substr( $_[0], $_[5] ) =~ m/(?i)$rx/ + : substr( $_[0], $_[5] ) =~ m/$rx/; + $_[3] = Pugs::Runtime::Match->new({ + bool => \$bool, + str => \$_[0], + from => \(0 + $_[5]), + to => \($_[5] + length $1), + named => {}, + match => [], + }); + }; +} + +sub null { + no warnings qw( uninitialized ); + return sub { + $_[3] = Pugs::Runtime::Match->new({ + bool => \1, + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + }); + } +}; + +sub failed { + no warnings qw( uninitialized ); + return sub { + $_[3] = Pugs::Runtime::Match->new({ + bool => \0, + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + state => undef, + }); + } +}; + +sub failed_abort { + no warnings qw( uninitialized ); + return sub { + $_[3] = Pugs::Runtime::Match->new({ + bool => \0, + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + abort => 1, + }); + } +}; + +sub named { + # return a named capture + my $label = shift; + my $capture_to_array = shift; + my $node = shift; + sub { + my $match; + $node->( @_[0,1,2], $match, @_[4,5,6,7] ); + my %matches; + $matches{ $label } = $capture_to_array ? [ $match ] : $match; + $_[3] = Pugs::Runtime::Match->new({ + bool => \( $match->bool ), + str => \$_[0], + from => \( $match->from ), + to => \( $match->to ), + named => \%matches, + match => [], + capture => $match->data->{capture}, + state => $match->state, + }); + } +} +sub capture { named(@_) } # backwards compat + +sub positional { + # return a positional capture + my $num = shift; + my $capture_to_array = shift; + my $node = shift; + sub { + my $match; + $node->( @_[0,1,2], $match, @_[4,5,6,7] ); + my @matches; + $matches[ $num ] = $capture_to_array ? [ $match ] : $match; + $_[3] = Pugs::Runtime::Match->new({ + bool => \( $match->bool ), + str => \$_[0], + from => \( $match->from ), + to => \( $match->to ), + named => {}, + match => \@matches, + capture => $match->data->{capture}, + state => $match->state, + }); + } +} + +sub capture_as_result { + # return a capture as the result object + my $node = shift; + sub { + my $match; + $node->( @_[0,1,2], $match, @_[4,5,6,7] ); + $_[3] = Pugs::Runtime::Match->new({ + bool => \( $match->bool ), + str => \$_[0], + from => \( $match->from ), + to => \( $match->to ), + named => {}, + match => [], + capture => ( + sub { + # print "Match: ", Dumper( $match ); + '' . $match + } + ), + state => $match->state, + }); + } +} + +sub ___abort { + my $op = shift; + return sub { + print "ABORTING\n"; + $op->( @_ ); + print "ABORT: [0] ",Dumper(@_); #$_[3]->perl; + $_[3]->data->{abort} = 1; + print "ABORT: ",$_[3]->perl; + }; +}; + +sub ___fail { + my $op = shift; + return abort( + sub { + print "FAILING\n"; + $op->( @_ ); + $_[3]->data->{bool} = \0; + print "FAIL: ",Dumper( $_[3] ); + } + ); +}; + +sub before { + my $op = shift; + return sub { + my $match; + $op->( @_[0,1,2], $match, @_[4,5,6,7] ); + $_[3] = Pugs::Runtime::Match->new({ + bool => \( $match->bool ), + str => \$_[0], + from => \( $match->from ), + to => \( $match->from ), + named => {}, + match => [], + state => $match->state, + }); + }; +} + +sub at_start { + no warnings qw( uninitialized ); + return sub { + $_[3] = Pugs::Runtime::Match->new({ + bool => \( $_[5] == 0 ), + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + abort => 0, + }); + } +}; + +sub at_line_start { + no warnings qw( uninitialized ); + return sub { + my $bool = $_[5] == 0 + || substr( $_[0], 0, $_[5] ) =~ /\n$/s; + $_[3] = Pugs::Runtime::Match->new({ + bool => \$bool, + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + abort => 0, + }); + } +}; + +sub at_line_end { + no warnings qw( uninitialized ); + return sub { + my $bool = $_[5] >= length( $_[0] ) + || substr( $_[0], $_[5] ) =~ /^\n/s; + $_[3] = Pugs::Runtime::Match->new({ + bool => \$bool, + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + abort => 0, + }); + } +}; + +sub at_end_of_string { + no warnings qw( uninitialized ); + return sub { + $_[3] = Pugs::Runtime::Match->new({ + bool => \( $_[5] == length( $_[0] ) ), + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + abort => 0, + }); + } +}; + +# experimental! +sub negate { + my $op = shift; + return sub { + #my $str = $_[0]; + my $match = $op->( @_ ); + my $bool = ! $match; + + $_[3] = Pugs::Runtime::Match->new({ + bool => \( $bool ), + str => \$_[0], + from => \(0 + $_[5]), + to => \(0 + $_[5]), + named => {}, + match => [], + abort => 0, + }); + + }; +}; + +# ------- higher-order ruleops + +sub optional { + my $node = shift; + alternation( [ $node, null() ] ); +} + +sub null_or_optional { + my $node = shift; + alternation( [ null(), $node ] ); +} + +sub greedy_star { + greedy_plus( $_[0], $_[1] || 0, $_[2] ) +} + +sub non_greedy_star { + non_greedy_plus( $_[0], $_[1] || 0, $_[2] ) +} + +# XXX - needs optimization for faster backtracking, less stack usage +# TODO - run-time ranges (iterator) +sub greedy_plus { + my $node = shift; + my $min_count = defined( $_[0] ) ? $_[0] : 1; + my $max_count = $_[1]; + if ( defined $max_count + && $max_count < 1e99 + ) { + return concat( [ + ( $node ) x $min_count, + ( optional( $node ) ) x ($max_count - $min_count) + ] ); + } + # $max_count == infinity + my $alt; + $alt = concat( [ + $node, + optional( sub{ goto $alt } ), + ] ); + return optional( $alt ) if $min_count < 1; + return concat( [ ( $node ) x ($min_count - 1), $alt ] ); +} + +# XXX - needs optimization for faster backtracking, less stack usage +# TODO - run-time ranges (iterator) +sub non_greedy_plus { + my $node = shift; + my $min_count = defined( $_[0] ) ? $_[0] : 1; + my $max_count = $_[1] || 1e99; + return sub { + my $state = $_[1] + || { node => concat( [ ( $node ) x $min_count ] ), + count => $min_count }; + return failed()->(@_) + if $state->{count} > $max_count; + $state->{node}->( $_[0], undef, @_[2..7] ); + $_[3]->data->{state} = + { node => concat( [ $node, $state->{node} ] ), + count => $state->{count} + 1 }; + } +} + +sub range { + my $node = shift; + my $min_count = shift; + my $max_count = shift; + my $greedy = not shift; + return sub { + + my $continuation = $_[1]; #XXX how do optional continuations work? + + # Forward declarations + + my $try_getting_more; + + my $default_behavior; + my $fallback_behavior; + + # Loop variables + + my $count = 0; + my $previous_pos = -1; + + # Loop 1 - getting to min_count + + my $continue_towards_min; + my $get_minimum = sub { + if ( $count < $min_count ) { + $count++; + goto &$continue_towards_min; + } else { + goto &$try_getting_more; + } + }; + $continue_towards_min = concat( [ $node, $get_minimum ] ); + + # Loop 2 - beyond the minimum + + $try_getting_more = sub { + + my $current_pos = $_[5]; + + # (1) Stop when max_count is reached, or if pos does not move. + + if ( !( $count < $max_count ) || + !( $previous_pos < $current_pos ) ) + { + goto &$continuation; + } + $count++; + $previous_pos = $current_pos; + + # (2) Attempt the default behavior. + + # XXX - This section needs to be filled in. + # try $default_behavior + # if successful, return. + # if abort, do whatever is needed. + # if fail, we need to backtrack: + # undo any side-effects from trying the $default_behavior, + # so we can do the $fallback_behavior. + + # (3) Since the default behavior failed, do the fall-back beharvior. + + goto &$fallback_behavior; + + }; + my $get_one_and_maybe_more = concat( [ $node, $try_getting_more ] ); + + # Final preparations. + + if ( $greedy ) { + $default_behavior = $get_one_and_maybe_more; + $fallback_behavior = $continuation; + } else { # non-greedy + $default_behavior = $continuation; + $fallback_behavior = $get_one_and_maybe_more; + } + + # Start. + + goto &$get_minimum; + }; +} + + +sub preprocess_hash { + # TODO - move to Pugs::Runtime::Regex + my ( $h, $key ) = @_; + # returns AST depending on $h + #print "preprocess_hash: ", Dumper( \@_ ); + if ( ref( $h->{$key} ) eq 'CODE') { + return sub { + my ( $str, $grammar, $args ) = @_; + #print "data: ", Dumper( \@_ ); + my $ret = $h->{$key}->( @_ ); + #print "ret: ", Dumper( $ret ); + + return $ret + if ref( $ret ) eq 'Pugs::Runtime::Match'; + + Pugs::Runtime::Match->new( { + bool => \1, + str => \$str, + from => \( 0 + ( $args->{p} || 0 ) ), + to => \( 0 + ( $args->{p} || 0 ) ), + named => {}, + match => [], + } ) } + } + if ( ref( $h->{$key} ) =~ /Pugs::Compiler::/ ) { + return sub { $h->{$key}->match( @_ ) }; + } + # fail is number != 1 + if ( $h->{$key} =~ /^(\d+)$/ ) { + return sub { + my ( $str, $grammar, $args ) = @_; + Pugs::Runtime::Match->new( { + bool => \0, + str => \$str, + from => \( 0 + ( $args->{p} || 0 ) ), + to => \( 0 + ( $args->{p} || 0 ) ), + named => {}, + match => [], + } ) } unless $1 == 1; + return sub { + my ( $str, $grammar, $args ) = @_; + Pugs::Runtime::Match->new( { + bool => \1, + str => \$str, + from => \( 0 + ( $args->{p} || 0 ) ), + to => \( 0 + ( $args->{p} || 0 ) ), + named => {}, + match => [], + } ) }; + } + # subrule + #print "compile: ",$h->{$key}, "\n"; + + # XXX - compile to Token or to Regex ? (v6.pm needs Token) + my $r = Pugs::Compiler::Token->compile( $h->{$key} ); + $h->{$key} = $r; + return sub { $r->match( @_ ) }; + # return sub { warn "uncompiled subrule: $h->{$key} - not implemented " }; +} + +# see commit #9783 for an alternate implementation +sub hash { + my %hash = %{shift()}; + #print "HASH: @{[ %hash ]}\n"; + my @keys = sort {length $b <=> length $a } keys %hash; + #print "hash keys [ @keys ]\n"; + for ( @keys ) { + my $h = preprocess_hash( \%hash, $_ ); + my $key = $_; + $_ = + concat( [ + constant( $key ), + sub { + # print "hash param: ",Dumper(\@_); + # TODO - add $ to $_[7] + $_[3] = $h->( $_[0], $_[4], $_[7], $_[1] ); + # print "result: ",Dumper($_[3]); + } + ] ); + } + return alternation( \@keys ); +} + +# not a 'rule node' +# gets a variable from the user's pad +# this is used by the <$var> rule +sub get_variable { + my $name = shift; + + local $@; + my($idx, $pad) = 0; + while(eval { require PadWalker; $pad = PadWalker::peek_my($idx) }) { + $idx++, next + unless exists $pad->{$name}; + + #print "NAME $name $pad->{$name}\n"; + return ${ $pad->{$name} } if $name =~ /^\$/; + return $pad->{$name}; # arrayref/hashref + } + croak "Couldn't find '$name' in surrounding lexical scope."; +} + + +1; + +__END__ + +=for About + +Original file: pX/Common/iterator_engine.pl - fglock + +TODO + +- There are no tests yet for , hashes, end_of_string + +- It needs a 'direction' flag, in order to implement . + +- Quantified matches could use less stack space. + +- Simplify arg list - the functions currently take 8 arguments. + +- weaken self-referential things + +=cut + +=pod + +A "rule" function gets as argument a list: + +0 - the string to match +1 - an optional "continuation" +2 - the partially built match tree +3 - a leaf pointer in the match tree +4 - the grammar name +5 - pos +#6 - the whole string to match +7 - argument list - + +it modifies argument #3 to a Match object: + + bool - an "assertion" (true/false) + from - string pointer for start of this match + to - string pointer for next match (end+1) + match - positional submatches + named - named submatches + capture - return'ed things + + state - a "continuation" or undef + abort - the match was stopped by a { return } or a fail(), + and it should not backtrack or whatever + +A "ruleop" function gets some arguments and returns a "rule" funtion. + +=cut + +=for later +# experimental! +sub try { + my $op = shift; + return sub { + my $match = $op->( @_ ); + ### abortable match... + $match->{abort} = 0; + return $match; + }; +}; + +=cut + +=for later + +sub fail { + return abort( + sub { + return { bool => \0 }; + } + ); +}; + +=cut + +# experimental! + +=for example + # adds an 'before' or 'after' sub call, which may print a debug message + wrap( { + before => sub { print "matching variable: $_[0]\n" }, + after => sub { $_[0]->{bool} ? print "matched\n" : print "no match\n" }, + }, + \&variable + ) +=cut + +=for later +sub wrap { + my $debug = shift; + my $node = shift; + sub { + $debug->{before}( @_ ) if $debug->{before}; + my $match = $node->( @_ ); + $debug->{after}( $match, @_ ) if $debug->{after}; + return $match; + } +} +=cut + diff --git a/blib6/pugs/perl5/lib/Pugs/Runtime/Rule.pm b/blib6/pugs/perl5/lib/Pugs/Runtime/Rule.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Runtime/Rule.pm @@ -0,0 +1,5 @@ +package Pugs::Runtime::Rule; + +die __PACKAGE__; + +1; diff --git a/blib6/pugs/perl5/lib/Pugs/Runtime/StrPos.pm b/blib6/pugs/perl5/lib/Pugs/Runtime/StrPos.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Runtime/StrPos.pm @@ -0,0 +1,230 @@ +package Pugs::Runtime::StrPos; +# Documentation in the __END__ + +#use 5.006; ??? +use strict; +use warnings; +use utf8; +use Data::Dumper; + +use overload ( + 'bool' => \&bool, + '0+' => \&graphs, + '++' => sub { + $_[0]->{codes} = ($_[0]->add_graphs( 1 ))->{codes}; + }, + '+=' => sub { + $_[0]->{codes} += $_[1]; + }, + '+' => sub { + ($_[0]->add_graphs( $_[1] ))->{codes}; + }, + '=' => sub { + my $self = shift; + bless {%$self}, ref $self; + }, + fallback => 1, +); + +# new({ str => "...", codes => $n }); +# $str must be utf-8 +# $n can be undef, meaning "nowhere in this string" +sub new { + return bless $_[1], $_[0]; +} + +# codes is the default perl5 representation +# graphs is the default perl6 representation +sub from_str_graphs { + + # -- downgrade as appropriate + #die "string has invalid internal encoding" + return from_str_codes( @_ ) + unless utf8::is_utf8( $_[1] ); + + $_[1] =~ m/^\X{$_[2]}/g; + return bless { str => $_[1], codes => pos($_[1]) }, $_[0]; +} + +sub from_str_codes { + return bless { str => $_[1], codes => $_[2] }, $_[0]; +} + +sub from_str { + return bless { str => $_[1], codes => pos( $_[1] ) }, $_[0]; +} + +sub clone { + return bless { %{$_[0]} }, ref( $_[0] ); +} + +sub bool { + defined $_[0]->{codes} +} + +sub codes { + $_[0]->{codes} +} + +sub bytes { + return undef unless defined $_[0]->{codes}; + + # -- downgrade as appropriate + #die "string has invalid internal encoding" + return $_[0]->codes + unless utf8::is_utf8( $_[0]->{str} ); + + my $s = substr( $_[0]->{str}, 0, $_[0]->{codes} ); + { + use bytes; + return length( $s ); + } + #my @bytes = unpack("C*", substr( $_[0]->{str}, 0, $_[0]->{codes} ) ); + #print "[",join(",", @bytes),"]\n"; + #return scalar @bytes; +} + +sub graphs { + return undef unless defined $_[0]->{codes}; + + # -- downgrade as appropriate + #die "string has invalid internal encoding" + return $_[0]->codes + unless utf8::is_utf8( $_[0]->{str} ); + + #return scalar( substr( $_[0]->{str}, 0, $_[0]->{codes} ) =~ m/\X/g ); + my @g = substr( $_[0]->{str}, 0, $_[0]->{codes} ) =~ m/\X/g; + return scalar @g; +} + +sub langs { + die "TODO: langs()"; +} + +sub add_codes { + (ref $_[0])->from_str_codes( $_[0]->{str}, $_[0]->codes + $_[1] ); +} + +sub add_graphs { + (ref $_[0])->from_str_graphs( $_[0]->{str}, $_[0]->graphs + $_[1] ); +} + +sub perl { + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Pad = ' '; + return Dumper( $_[0] ); +} + +sub yaml { + require YAML::Syck; + # interoperability with other YAML/Syck bindings: + $YAML::Syck::ImplicitTyping = 1; + YAML::Syck::Dump( $_[0] ); +} + +# for Pugs interoperability +sub dump_hs { + die "TODO"; +} + +1; + +__END__ + +=head1 NAME + +Pugs::Runtime::StrPos - Represent a position inside a string + +=head1 OPTIONAL MODULES + +* YAML::Syck + +- in order to support 'yaml()' + +=head1 METHODS + +* new({ str => "...", codes => $n }); + +create a new StrPos object. + +'str' must be utf-8. + +'codes' can be undef, meaning "nowhere in this string". + +* from_str( $str ) + +create a new StrPos object, using the perl5-string internal 'pos'. + +* from_str_graphs( $str, $graphs ) +* from_str_codes( $str, $codes ) + +create a new StrPos object using grapheme or codepoint units. + +* bytes() +* codes() +* graphs() + +- return the position as an integer, counting in bytes, codepoints, or graphemes. + +* langs() + +- TODO - return the position as an integer, counting in language dependent chars. + +* bool() + +- test whether a position is defined. + +* add_codes($n) +* add_graphs($n) + +- return a new StrPos with the new position + +* clone + +- return a new StrPos with the same position + +=head1 OVERLOADS + +* numeric + +- return the count of graphemes, or undef. + +* boolean + +- test whether a position is defined. The position 'zero' is true. + +=head1 Dumper methods + +* perl + +- return the internal representation as Perl source code. + +* yaml + +- return the internal representation as YAML. +Requires the C module. + +* dump_hs + +- for Pugs interoperability + +=head1 SEE ALSO + +C on CPAN + +=head1 AUTHORS + +The Pugs Team Eperl6-compiler@perl.orgE. + +=head1 COPYRIGHT + +Copyright 2007 by Flavio Soibelmann Glock and others. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L + +=cut + diff --git a/blib6/pugs/perl5/lib/Pugs/Runtime/Tracer.pm b/blib6/pugs/perl5/lib/Pugs/Runtime/Tracer.pm new file mode 100644 --- /dev/null +++ b/blib6/pugs/perl5/lib/Pugs/Runtime/Tracer.pm @@ -0,0 +1,124 @@ +package Pugs::Runtime::Tracer; + +use strict; +use warnings; +use base 'Exporter'; +#use Smart::Comments; + +our @EXPORT = qw( + trace_begin trace_end trace + expand_tracing_code +); + +sub trace_begin ($$$$) { + my ($name, $from, $to, $pos) = @_; + trace(">>BEGIN $name<< $from..$to at $pos\n"); +} + +sub trace_end ($$$) { + my ($name, $res, $pos) = @_; + trace(">>END $name<< ", $res ? 'success' : 'fail', " at $pos\n"); +} + +sub trace ($@) { + if (!defined $::PCR_TRACE_FH) { + $::PCR_TRACE_FH = \*STDOUT; + } + print $::PCR_TRACE_FH @_; +} + +sub expand_tracing_code { + my $s = shift; + open my $in, '<', \$s or die; + my (@names, $name, $new, @has_pos); + while (<$in>) { + chomp; + if (/\s+## <(\w+)>$/) { + $name = $1; + push @names, $name; + push @has_pos, 0; + ### begin: $name + $new .= $_ . "\n"; + } elsif (/(\s+)## pos: (\d+) (\d+)$/) { + my ($tab, $from, $to) = ($1, $2, $3); + $has_pos[-1] = 1; + $new .= <<"_EOC_"; +$_ +$tab do { +$tab Pugs::Runtime::Tracer::trace_begin('$name', $from, $to, \$pos); +$tab my \$retval = +_EOC_ + } elsif (/(\s+)## <\/(\w+)>$/) { + my ($tab, $n) = ($1, $2); + $name = pop @names; + my $has_pos = pop @has_pos; + ### end: $n . "<=>" . $name + if (!defined $name || $n ne $name) { + die "ERROR: unexpected closing tag "; + } elsif ($has_pos) { + $new .= <<"_EOC_"; +$_ +$tab ; +$tab Pugs::Runtime::Tracer::trace_end('$name', \$retval, \$pos); +$tab \$retval; +$tab } +_EOC_ + } + if (!$has_pos) { + #warn "No pos info found for <$n>"; + } + } else { + $new .= $_ . "\n"; + } + } + return $new; +} + +1; +__END__ + +=head1 NAME + +Pugs::Runtime::Tracer - tracer runtime for Pugs::Compiler::Rule + +=head1 SYNOPSIS + + use Pugs::Runtime::Tracer; + trace("blah blah blah"); + trace_begin($regex_name, $regex_pos_from, $regex_pos_to, $input_pos); + trace_end($regex_name, $success, $input_pos); + $perl5_code_with_tracing_code = expand_tracing_code($perl5_code); + +=head1 DESCRIPTION + +This module provides tracing facilities for both PCR compile-time and run-time. + +=head1 SEE ALSO + +=over + +=item * + +L + +=item * + +"A graphical tracer for Perl 6 regexes based on PCR" + +L. + +=back + +=head1 AUTHOR + +Agent Zhang Eagentzh@yahoo.cnE. + +=head1 COPYRIGHT + +Copyright 2007 by Yahoo! China Inc. L. + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + diff --git a/perl5/p5embed.c b/perl5/p5embed.c new file mode 100644 --- /dev/null +++ b/perl5/p5embed.c @@ -0,0 +1,590 @@ +#include "p5embed.h" +#include +#include "perlxsi.c" +#include "pugsembed.c" + +/* define to enable pugsembed debug messages */ +#define PERL5_EMBED_DEBUG 0 + +#if PERL5_EMBED_DEBUG +#define oRZ "" +#define hate Perl_croak(aTHX_ "hate software") +#else +#define oRZ "#" +#define hate +#endif + +/* Workaround for mapstart: the only op which needs a different ppaddr */ +#undef Perl_pp_mapstart +#define Perl_pp_mapstart Perl_pp_grepstart +#undef OP_MAPSTART +#define OP_MAPSTART OP_GREPSTART + +static PerlInterpreter *my_perl; + +int _P5EMBED_INIT = 0; + +const char pugs_guts_code[] = +"use strict;\n\n" + +"package pugs;\n\n" + +"our $AUTOLOAD;\n" +"sub AUTOLOAD { pugs::guts::invoke($AUTOLOAD, @_) } \n" +"sub DESTROY {}\n\n" + +"package pugs::guts;\n" +"our @ISA=('pugs');\n" +"sub Code { my ($class, $val) = @_;\n" +" sub { pugs::guts::invoke($val, undef, @_) } }\n" + +"sub Array { my ($class, $val) = @_;\n" +" my $array; tie @$array, 'pugs::array', $val;\n" +oRZ" warn 'returning '.$array;\n" +" return $array; }\n\n" + +"sub Hash { my ($class, $val) = @_;\n" +" my $hash; tie %$hash, 'pugs::hash', $val;\n" +oRZ" warn 'returning '.$hash;\n" +" return $hash; }\n\n" + +"sub Pair { goto &Hash }\n" + +"sub Scalar { my ($class, $val) = @_;\n" +" my $scalar; tie $$scalar, 'pugs::scalar', $val;\n" +oRZ" warn 'returning '.$scalar;\n" +" return $scalar; }\n\n" + +"sub Handle { my ($class, $val) = @_;\n" +" tie *FH, 'pugs::handle', $val;\n" +oRZ" warn 'returning '.$handle;\n" +" return *FH; }\n\n" + +"our $AUTOLOAD;\n" +"sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n" +" return if $type =~ m/^[A-Z]*$/; die 'unhandled support type: '.$type } \n" +oRZ"warn 'compiled .'.__PACKAGE__;\n\n" + +"package pugs::array;\n" + +"our $AUTOLOAD;\n" + +"sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n" +" warn 'unhandled support type: '.$type } \n" + +"sub TIEARRAY {\n" +" my ($class, $val) = @_;\n" +" bless \\$val, $class; }\n\n" + +"sub DEREF { ${$_[0]} }\n" + +"sub STORE {\n" +" my ($self, $index, $elem) = @_;\n" +oRZ" warn 'store! '.$elem;\n" +" pugs::guts::eval_apply('sub ($x is rw, $y is rw, $z is rw) { item($x[$y] = $z);\n" +oRZ" warn $x\n" +" }', $$self, $index, $elem) }\n\n" + +"sub PUSH {\n" +" my ($self, @elems) = @_;\n" +" pugs::guts::eval_apply('sub ($x is rw, @*y) { item $x.push(@y);\n" +oRZ" warn $x\n" +" }', $$self, @elems) }\n\n" + +"sub FETCHSIZE {\n" +" my ($self) = @_;\n" +" my $ret = pugs::guts::invoke('elems', $$self); \n" +oRZ" warn 'FETCHSIZE: '.$ret;\n" +" $ret; }\n\n" + +"sub EXISTS {\n" +" my ($self, $index) = @_;\n" +" pugs::guts::eval_apply('sub ($x, $y) { item $x.exists($y) }', $$self, $index) }\n" + +"sub FETCH {\n" +" my ($self, $index) = @_;\n" +oRZ" warn 'FETCH: '.$index;\n" +" pugs::guts::eval_apply('sub ($x, $y) { item $x.[$y] }', $$self, $index) }\n" + +"package pugs::hash;\n" + +"our $AUTOLOAD;\n" +"sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n" +" warn 'unhandled support type: '.$type } \n" + +"sub TIEHASH {\n" +" my ($class, $val) = @_;\n" +" bless [$val,0], $class; }\n\n" + +"sub DEREF { $_[0][0] }\n" + +"sub FETCH {\n" +" my ($self, $index) = @_;\n" +oRZ" warn 'FETCH: '.$index;\n" +" pugs::guts::eval_apply('sub ($x, $y) { item $x.{$y} }', $self->[0], $index) }\n" + +"sub DELETE {\n" +" my ($self, $index) = @_;\n" +oRZ" warn 'DELETE: '.$index;\n" +" pugs::guts::eval_apply('sub ($x, $y) { item $x.delete($y) }', $self->[0], $index) }\n" + +"sub CLEAR {\n" +" my ($self) = @_;\n" +" pugs::guts::eval_apply('sub ($x) { item $x.delete($x.keys) }', $self->[0]) }\n" + +"sub STORE {\n" +" my ($self, $index, $elem) = @_;\n" +oRZ" warn 'store! '.$elem;\n" +" pugs::guts::eval_apply('sub ($x is rw, $y, $z) { item($x{$y} = $z);\n" +oRZ" warn $x\n" +" }', $self->[0], $index, $elem) }\n\n" + +"sub FIRSTKEY {\n" +" my ($self) = @_;\n" +" my $ret = pugs::guts::invoke('keys', $self->[0]); \n" +oRZ" warn $ret;\n" +" $self->[1] = 0; $self->[2] = $ret;" +" $self->NEXTKEY; }\n" + +"sub NEXTKEY {\n" +" my ($self) = @_;\n" +" return undef if $self->[1] > $#{$self->[2]};" +" $self->[2]->[$self->[1]++]; }" + +"package pugs::scalar;\n" + +"our $AUTOLOAD;\n" +"sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n" +" warn 'unhandled support type: '.$type } \n" + +"sub TIESCALAR {\n" +" my ($class, $val) = @_;\n" +" bless \\$val, $class; }\n\n" + +"sub DEREF { ${$_[0]} }\n" + +"sub FETCH {\n" +" my ($self) = @_;\n" +" pugs::guts::eval_apply('sub ($x) { ~$x }', $$self) }\n" + +"sub STORE {\n" +" my ($self, $val) = @_;\n" +" pugs::guts::eval_apply('sub ($x is rw, $y) { $$x = $y;\n" +oRZ" warn $x\n" +" }', $$self, $val) }\n\n" + +"package pugs::handle;\n" + +"our $AUTOLOAD;\n" +"sub AUTOLOAD { my $type = $AUTOLOAD; $type =~ s/.*:://;\n" +" warn 'unhandled support type: '.$type } \n" + +"sub TIEHANDLE {\n" +" my ($class, $val) = @_;\n" +" bless \\$val, $class; }\n\n" + +"sub DEREF { ${$_[0]} }\n" + +"sub PRINT {\n" +" my ($self, @vals) = shift;\n" +" pugs::guts::eval_apply('sub ($x, *@y) { $x.print(@y) }', $$self, @vals) }\n" + +"sub READLINE {\n" +" my ($self) = @_;\n" +" pugs::guts::eval_apply('sub ($x) { ~($x.readline);\n" +oRZ" warn $x\n" +" }', $$self) }\n\n" + +"sub GETC {\n" +" my ($self) = @_;\n" +" pugs::guts::eval_apply('sub ($x) { ~($x.getc);\n" +oRZ" warn $x\n" +" }', $$self) }\n\n" + +oRZ"warn 'compiled';\n" +"1;\n"; + +XS(_pugs_guts_invoke) { + Val *val, *inv, **stack; + SV *ret, *sv; + int i; + dXSARGS; + if (items < 1) { + hate; + } + + sv = ST(0); + if (sv_isa(sv, "pugs")) { + val = pugs_SvToVal(ST(0)); + } + else { + char *method, *fullname; + fullname = SvPV_nolen(sv); + method = strrchr(fullname, ':'); + method = method ? method+1 : fullname; + val = pugs_PvnToVal(method, strlen(method)); + } + inv = SvOK(ST(1)) ? pugs_SvToVal(ST(1)) : NULL; + + New(6, stack, items, Val*); + + for (i = 2; i < items; ++i) { + stack[i-2] = pugs_SvToVal(ST(i)); + } + stack[i-2] = NULL; + + ST(0) = pugs_Apply(val, inv, stack, GIMME_V); + /* sv_dump (ret); */ + Safefree(stack); + + XSRETURN(1); +} + + +XS(_pugs_guts_eval_apply) { + Val *val, *inv, **stack; + int i; + dXSARGS; + if (items < 1) { + hate; + } + + val = pugs_Eval(SvPV_nolen(ST(0))); + + New(6, stack, items, Val*); + + for (i = 1; i < items; ++i) { +#if PERL5_EMBED_DEBUG + fprintf(stderr, "put into stack: %s\n", SvPV_nolen(ST(i))); +#endif + stack[i-1] = pugs_SvToVal(ST(i)); + } + stack[i-1] = NULL; + + ST(0) = pugs_Apply(val, NULL, stack, GIMME_V); + Safefree(stack); + + XSRETURN(1); +} + + +#ifdef HAS_PROCSELFEXE +/* This is a function so that we don't hold on to MAXPATHLEN + bytes of stack longer than necessary + */ +STATIC void +S_procself_val(pTHX_ SV *sv, char *arg0) +{ + char buf[MAXPATHLEN]; + int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); + + /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) + includes a spurious NUL which will cause $^X to fail in system + or backticks (this will prevent extensions from being built and + many tests from working). readlink is not meant to add a NUL. + Normal readlink works fine. + */ + if (len > 0 && buf[len-1] == '\0') { + len--; + } + + /* FreeBSD's implementation is acknowledged to be imperfect, sometimes + returning the text "unknown" from the readlink rather than the path + to the executable (or returning an error from the readlink). Any valid + path has a '/' in it somewhere, so use that to validate the result. + See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 + */ + if (len > 0 && memchr(buf, '/', len)) { + sv_setpvn(sv,buf,len); + } + else { + sv_setpv(sv,arg0); + } +} +#endif /* HAS_PROCSELFEXE */ + +# if defined(__APPLE__) +# include /* for the env array */ +# define p5embed_environ (*_NSGetEnviron()) +# else +# define p5embed_environ environ +# endif + +PerlInterpreter * +perl5_init ( int argc, char **argv ) +{ + int exitstatus; + int i; + +#ifdef PERL_GPROF_MONCONTROL + PERL_GPROF_MONCONTROL(0); +#endif +#ifdef PERL_SYS_INIT3 + PERL_SYS_INIT3(&argc,&argv,&p5embed_environ); +#endif + +#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && defined(HAS_PTHREAD_ATFORK) + /* XXX Ideally, this should really be happening in perl_alloc() or + * perl_construct() to keep libperl.a transparently fork()-safe. + * It is currently done here only because Apache/mod_perl have + * problems due to lack of a call to cancel pthread_atfork() + * handlers when shared objects that contain the handlers may + * be dlclose()d. This forces applications that embed perl to + * call PTHREAD_ATFORK() explicitly, but if and only if it hasn't + * been called at least once before in the current process. + * --GSAR 2001-07-20 */ + PTHREAD_ATFORK(Perl_atfork_lock, + Perl_atfork_unlock, + Perl_atfork_unlock); +#endif + + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + exit(1); + perl_construct( my_perl ); + PL_perl_destruct_level = 0; + } +#ifdef PERL_EXIT_DESTRUCT_END + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; +#endif /* PERL_EXIT_DESTRUCT_END */ +#ifdef PERL_EXIT_EXPECTED + PL_exit_flags |= PERL_EXIT_EXPECTED; +#endif /* PERL_EXIT_EXPECTED */ + +#if (defined(CSH) && defined(PL_cshname)) + if (!PL_cshlen) + PL_cshlen = strlen(PL_cshname); +#endif + + exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL); + + if (exitstatus == 0) + exitstatus = perl_run( my_perl ); + + _P5EMBED_INIT = 1; + + newXS((char*) "pugs::guts::invoke", _pugs_guts_invoke, (char*)__FILE__); + newXS((char*) "pugs::guts::eval_apply", _pugs_guts_eval_apply, (char*)__FILE__); + +#if PERL5_EMBED_DEBUG + fprintf(stderr, "(%s)", pugs_guts_code); +#endif + eval_pv(pugs_guts_code, TRUE); + + if (SvTRUE(ERRSV)) { + STRLEN n_a; + printf("Error init perl: %s\n", SvPV(ERRSV,n_a)); + exit(1); + } + return my_perl; +} + +char * +perl5_SvPV ( SV *sv ) +{ + char *rv; + rv = SvPV_nolen(sv); + return rv; +} + +int +perl5_SvIV ( SV *sv ) +{ + return((int)SvIV(sv)); +} + +double +perl5_SvNV ( SV *sv ) +{ + return((double)SvNV(sv)); +} + +bool +perl5_SvTRUE ( SV * sv ) +{ + bool rv; + rv = SvTRUE(sv); + return(rv ? 1 : 0); +} + +bool +perl5_SvROK ( SV * sv ) +{ + bool rv; + sv_dump(sv); + rv = SvROK(sv); + return(rv ? 1 : 0); +} + +SV * +perl5_sv_undef () +{ + return(&PL_sv_undef); +} + +SV * +perl5_newSVpvn ( char * pv, int len ) +{ + SV *sv = newSVpvn(pv, len); +#ifdef SvUTF8_on + SvUTF8_on(sv); +#endif + return(sv); +} + +SV * +perl5_newSViv ( int iv ) +{ + return(newSViv(iv)); +} + +SV * +perl5_newSVnv ( double iv ) +{ + return(newSVnv(iv)); +} + +SV ** +perl5_apply(SV *sub, SV *inv, SV** args, void *env, int cxt) +{ + SV **arg; + SV **out; + SV *rv; + SV *sv; + void *old_env = pugs_getenv(); + int count, i; + + dSP; + + ENTER; + SAVETMPS; + + pugs_setenv(env); + + PUSHMARK(SP); + if (inv != NULL) { + XPUSHs(inv); + } + for (arg = args; *arg != NULL; arg++) { + XPUSHs(*arg); + } + PUTBACK; + + if (inv != NULL) { + count = call_method(SvPV_nolen(sub), cxt|G_EVAL); + } + else { + count = call_sv(sub, cxt|G_EVAL); + } + + SPAGAIN; + + if (SvTRUE(ERRSV)) { + Newz(42, out, 3, SV*); + if (SvROK(ERRSV)) { + out[0] = newSVsv(ERRSV); + out[1] = NULL; + } + else { + out[0] = ERRSV; + out[1] = ERRSV; /* for Haskell-side to read PV */ + } + out[2] = NULL; + } + else { + Newz(42, out, count+2, SV*); + + out[0] = NULL; + + for (i=count; i>0; --i) { + out[i] = newSVsv(POPs); + } + out[count+1] = NULL; + } + + PUTBACK; + FREETMPS; + LEAVE; + + pugs_setenv(old_env); + return out; +} + +SV * +perl5_get_sv(const char *name) +{ + SV *sv = get_sv(name, 1); + /* sv_dump(sv); */ + return sv; +} + +SV * +perl5_eval(char *code, void *env, int cxt) +{ + dSP; + SV* sv; + void *old_env = pugs_getenv(); + + ENTER; + SAVETMPS; + + pugs_setenv(env); + + sv = newSVpv(code, 0); +#ifdef SvUTF8_on + SvUTF8_on(sv); +#endif + eval_sv(sv, cxt); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + SvREFCNT_inc(sv); + PUTBACK; + + if (SvTRUE(ERRSV)) { + STRLEN n_a; + fprintf(stderr, "Error eval perl5: \"%s\"\n*** %s\n", code, SvPV(ERRSV,n_a)); + } + + FREETMPS; + LEAVE; + + pugs_setenv(old_env); + return sv; +} + +bool +perl5_can(SV *inv, char *subname) +{ + int rv; + + dSP; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(inv); + XPUSHs(newSVpv(subname, 0)); + PUTBACK; + + call_pv("UNIVERSAL::can", G_SCALAR); + + SPAGAIN; + + rv = (POPi != 0); + /* printf("Checking: %s->can(%s), ret %d\n", SvPV_nolen(inv), subname, rv); */ + + PUTBACK; + FREETMPS; + LEAVE; + + return rv; +} + +void perl5_finalize ( SV* sv ) +{ + SvREFCNT_dec(sv); +} diff --git a/src/Pugs/Embed/Perl5.hs b/src/Pugs/Embed/Perl5.hs --- a/src/Pugs/Embed/Perl5.hs +++ b/src/Pugs/Embed/Perl5.hs @@ -186,7 +186,8 @@ import Foreign.C.Types import Foreign.C.String import {-# SOURCE #-} Pugs.AST.Internals -import qualified UTF8 as Str +import qualified Data.ByteString.UTF8 as Str +import qualified Data.ByteString.Char8 as Buf import qualified Pugs.Val as Val type PerlInterpreter = Ptr () @@ -295,10 +296,10 @@ svUndef = perl5_sv_undef vstrToSV :: String -> IO PerlSV -vstrToSV str = Str.useAsCStringLen (cast str) $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len) +vstrToSV str = Buf.useAsCStringLen (cast str) $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len) bufToSV :: ByteString -> IO PerlSV -bufToSV str = Str.useAsCStringLen str $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len) +bufToSV str = Buf.useAsCStringLen str $ \(cstr, len) -> perl5_newSVpvn cstr (toEnum len) vintToSV :: (Integral a) => a -> IO PerlSV vintToSV int = perl5_newSViv (fromIntegral int) @@ -329,7 +330,7 @@ return $ Perl5ErrorString str canPerl5 :: PerlSV -> ByteString -> IO Bool -canPerl5 sv meth = Str.useAsCString meth $ \cstr -> perl5_can sv cstr +canPerl5 sv meth = Buf.useAsCString meth $ \cstr -> perl5_can sv cstr mkSV :: IO PerlSV -> IO PerlSV mkSV action = action @@ -341,7 +342,7 @@ -} evalPerl5 :: String -> PugsEnv -> CInt -> IO PerlSV -evalPerl5 str env cxt = mkSV $ Str.useAsCString (cast str) $ \cstr -> perl5_eval cstr env cxt +evalPerl5 str env cxt = mkSV $ Buf.useAsCString (cast str) $ \cstr -> perl5_eval cstr env cxt freePerl5 :: PerlInterpreter -> IO () freePerl5 my_perl = do diff --git a/src/Pugs/Prim/Match.hs b/src/Pugs/Prim/Match.hs --- a/src/Pugs/Prim/Match.hs +++ b/src/Pugs/Prim/Match.hs @@ -9,6 +9,7 @@ import Pugs.Types import Pugs.Config import Pugs.Prim.Code +import Paths_Pugs import qualified Data.Map as Map import qualified Data.Array as Array import qualified Pugs.Prim.FileTest as FileTest @@ -31,10 +32,7 @@ doMatch :: String -> VRule -> Eval VMatch doMatch cs rule@MkRulePGE{ rxRule = ruleStr } = do - let pwd1 = getConfig "installsitelib" ++ "/auto/pugs/perl5/lib" - pwd2 = getConfig "sourcedir" ++ "/perl5/Pugs-Compiler-Rule/lib" - hasSrc <- io $ doesDirectoryExist pwd2 - let pwd = if hasSrc then pwd2 else pwd1 + pwd <- io $ getDataFileName "blib6/pugs/perl5/lib" glob <- askGlobal let syms = [ (cast $ v_name var, entry) | (var, entry) <- padToList glob diff --git a/src/Pugs/Run/Perl5.hs b/src/Pugs/Run/Perl5.hs --- a/src/Pugs/Run/Perl5.hs +++ b/src/Pugs/Run/Perl5.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-warn-unused-binds -fno-warn-unused-imports -fallow-overlapping-instances #-} +{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-warn-unused-binds -fno-warn-unused-imports -fallow-overlapping-instances -optc-DSTABLE_H -optc-w #-} module Pugs.Run.Perl5 () where diff --git a/src/Pugs/Shell.hs b/src/Pugs/Shell.hs --- a/src/Pugs/Shell.hs +++ b/src/Pugs/Shell.hs @@ -45,7 +45,7 @@ -- parse the input and return the corresponding command getCommand :: Input Command getCommand = do - input <- liftM (fmap encodeUTF8) $ getInputLine "pugs> " + input <- fmap (fmap encodeUTF8) $ getInputLine "pugs> " doCommand input doCommand :: Maybe String -> Input Command @@ -75,7 +75,7 @@ initializeShell f = (`runInputT` f) =<< pugsSettings readline :: String -> IO (Maybe String) -readline prompt = (`runInputT` liftM (fmap encodeUTF8) (getInputLine prompt)) =<< pugsSettings +readline prompt = (`runInputT` fmap (fmap encodeUTF8) (getInputLine prompt)) =<< pugsSettings pugsSettings :: IO (Settings IO) pugsSettings = do diff --git a/src/Pugs/Version.hs b/src/Pugs/Version.hs --- a/src/Pugs/Version.hs +++ b/src/Pugs/Version.hs @@ -14,10 +14,10 @@ -- #include "pugs_version.h" #ifndef PUGS_VERSION -#define PUGS_VERSION "6.2.13.8" +#define PUGS_VERSION "6.2.13.9" #endif #ifndef PUGS_DATE -#define PUGS_DATE "July 19, 2008" +#define PUGS_DATE "July 25, 2008" #endif #ifndef PUGS_SVN_REVISION #define PUGS_SVN_REVISION 0