Marpa-R2-2.086000~dfsg/0000755000000000000000000000000012342464707013043 5ustar rootrootMarpa-R2-2.086000~dfsg/author.t/0000755000000000000000000000000012342464707014607 5ustar rootrootMarpa-R2-2.086000~dfsg/author.t/create_critic_list.pl0000555000000000000000000000273112342464707021003 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Fatal qw( open close ); my %exclude = map { ( $_, 1 ) } qw(); open my $manifest, '<', '../MANIFEST' or Marpa::R2::exception("open of ../MANIFEST failed: $ERRNO"); my @test_files = (); FILE: while ( my $file = <$manifest> ) { chomp $file; $file =~ s/\s*[#].*\z//xms; next FILE if $exclude{$file}; my ($ext) = $file =~ / [.] ([^.]+) \z /xms; given ( lc $ext ) { when (undef) { break } when ('pl') { say $file or die "Cannot say: $ERRNO" } when ('pm') { say $file or die "Cannot say: $ERRNO" } when ('t') { say $file or die "Cannot say: $ERRNO" } } ## end given } ## end while ( my $file = <$manifest> ) close $manifest; Marpa-R2-2.086000~dfsg/author.t/Makefile0000444000000000000000000000225512342464706016250 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. .PHONY: all all_tests critic display tidy all: all_tests critic.list: ../MANIFEST create_critic_list.pl perl ./create_critic_list.pl > critic.list all_tests: critic.list -(cd ..; prove author.t/*.t ) 2>&1 | tee all.errs tidy: critic.list -(cd ..; prove author.t/tidy.t) 2>&1 | tee tidy.errs critic: critic.list -(cd ..; prove author.t/critic.t) 2>&1 | tee critic.errs display: -(cd ..; prove author.t/display.t) 2>&1 | tee display.errs pod: -(cd ..; prove author.t/pod.t) Marpa-R2-2.086000~dfsg/author.t/critic10000555000000000000000000000017312342464707016072 0ustar rootroot#!/bin/sh cat $1 | ( cd ..; perlcritic --verbose '%l:%c %p %r\n' --exclude 'Dynamic::*' --profile author.t/perlcriticrc ) Marpa-R2-2.086000~dfsg/author.t/ampersand.t0000444000000000000000000000214612342464706016746 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use warnings; use strict; use Test::More tests => 5; use lib 'lib'; use lib 'blib/arch'; use lib 'inc'; use lib 'pperl'; BEGIN { Test::More::use_ok('Devel::SawAmpersand'); Test::More::use_ok('Marpa::R2'); Test::More::use_ok('Marpa::R2::Perl'); Test::More::use_ok('Marpa::R2::Test'); } ## end BEGIN Test::More::ok( !Devel::SawAmpersand::sawampersand(), 'PL_sawampersand set' ); Marpa-R2-2.086000~dfsg/author.t/spelling_exceptions.list0000444000000000000000000000111612342464706021556 0ustar rootrootGisle Aas AnnoCPAN Aycock BNF Chela Chela's Corion CPAN CPAN's del del's Desarmenien Dominus Dominus's dragonchild Earleme earleme earlemes Earley Earley's Horspool jdporter Juerd Kegler Khala LALR lex lexable lexables lexes lexing Lhotrak lhs Lotsawa Marpa Marpa's mdl MDL MDL's memoize memoizing Michaud Nalanda namespace namespaces nullable nulled online other's overriden perldoc perlmonks postfix precomputation precomputations precompute precomputes regex regexes regex's rhs samtregar stringified stringify stringifying th unstringified unstringify useable whitespace Wikipedia yacc Marpa-R2-2.086000~dfsg/author.t/perlcriticrc0000444000000000000000000002456012342464706017223 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # This perlcriticrc is intended to list all policies explicitly. # Defaults are set so that policies not explicitly included (perhaps # because they are new in the latest Perl::Critic release) # produce warnings. This is done by setting default severity to # 1, changing the severity of all policies I use to 5, and turning # off policies which are not used with a minus prepended to the # name of the module. severity = 1 color = 0 [-BuiltinFunctions::ProhibitBooleanGrep] severity=5 [BuiltinFunctions::ProhibitComplexMappings] severity=5 [BuiltinFunctions::ProhibitLvalueSubstr] severity=5 # I consider these OK, but I also like to document # them, and the override this forces enforces # my documentation requirement [BuiltinFunctions::ProhibitReverseSortBlock] severity=5 [BuiltinFunctions::ProhibitSleepViaSelect] severity=5 [BuiltinFunctions::ProhibitStringyEval] severity=5 [BuiltinFunctions::ProhibitStringySplit] severity=5 [BuiltinFunctions::ProhibitUniversalCan] severity=5 [BuiltinFunctions::ProhibitUniversalIsa] severity=5 [BuiltinFunctions::ProhibitVoidGrep] severity=5 [BuiltinFunctions::ProhibitVoidMap] severity=5 [BuiltinFunctions::RequireBlockGrep] severity=5 [BuiltinFunctions::RequireBlockMap] severity=5 [BuiltinFunctions::RequireGlobFunction] severity=5 [BuiltinFunctions::RequireSimpleSortBlock] severity=5 [ClassHierarchies::ProhibitAutoloading] severity=5 [ClassHierarchies::ProhibitExplicitISA] severity=5 [ClassHierarchies::ProhibitOneArgBless] severity=5 [CodeLayout::ProhibitHardTabs] severity=5 [CodeLayout::ProhibitParensWithBuiltins] severity=5 [CodeLayout::ProhibitQuotedWordLists] severity=5 [CodeLayout::ProhibitTrailingWhitespace] severity=5 [CodeLayout::RequireConsistentNewlines] severity=5 [CodeLayout::RequireTrailingCommas] severity=5 [CodeLayout::RequireTidyCode] severity=5 perltidyrc=author.t/perltidyrc [-ControlStructures::ProhibitCStyleForLoops] severity=5 [ControlStructures::ProhibitCascadingIfElse] severity=5 # Good advice, but it is pretty obvious # when it is happening, and Perl::Critic # doesn't need to point it out. [-ControlStructures::ProhibitDeepNests] severity=5 [ControlStructures::ProhibitMutatingListFunctions] severity=5 [ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions] severity=5 # These constructs are there because they can # be the clearest way to express the logic. # Disabling them is against the Perl spirit. [-ControlStructures::ProhibitPostfixControls] severity=5 # These constructs are there because they can # be the clearest way to express the logic. # Disabling them is against the Perl spirit. [-ControlStructures::ProhibitUnlessBlocks] severity=5 [ControlStructures::ProhibitUnreachableCode] severity=5 # These constructs are there because they can # be the clearest way to express the logic. # Disabling them is against the Perl spirit. [-ControlStructures::ProhibitUntilBlocks] severity=5 [-Documentation::RequirePodAtEnd] severity=5 [-Documentation::RequirePodSections] severity=5 lib_sections = NAME | DESCRIPTION | SUPPORT | AUTHOR | LICENSE AND COPYRIGHT script_sections = NAME | USAGE | OPTIONS | EXIT STATUS | AUTHOR # die() is good for Internal errors. [-ErrorHandling::RequireCarping] severity=5 [InputOutput::ProhibitBacktickOperators] severity=5 [InputOutput::ProhibitBarewordFileHandles] severity=5 [InputOutput::ProhibitExplicitStdin] severity=5 [InputOutput::ProhibitInteractiveTest] severity=5 [InputOutput::ProhibitJoinedReadline] severity=5 [InputOutput::ProhibitOneArgSelect] severity=5 [InputOutput::ProhibitReadlineInForLoop] severity=5 [InputOutput::ProhibitTwoArgOpen] severity=5 [InputOutput::RequireBracedFileHandleWithPrint] severity=5 [InputOutput::RequireBriefOpen] severity=5 lines=99 [InputOutput::RequireCheckedClose] severity=5 [InputOutput::RequireCheckedOpen] severity=5 [InputOutput::RequireCheckedSyscalls] severity=5 functions = :builtins [Miscellanea::ProhibitFormats] severity=5 [Miscellanea::ProhibitTies] severity=5 [-Miscellanea::RequireRcsKeywords] [Modules::ProhibitAutomaticExportation] severity=5 [Modules::ProhibitEvilModules] severity=5 [-Modules::ProhibitExcessMainComplexity] [-Modules::ProhibitMultiplePackages] [Modules::RequireBarewordIncludes] severity=5 [Modules::RequireEndWithOne] severity=5 [Modules::RequireExplicitPackage] severity=5 [-Modules::RequireFilenameMatchesPackage] [Modules::RequireNoMatchVarsWithUseEnglish] severity=5 [-Modules::RequireVersionVar] # I no longer use this because # 1.) Violations are obvious so perlcritic adds # limited value. # 2.) There are many good reasons to make exceptions. # 3.) Turning off violations on a case-by-case basis # is too noisy considering the severity. [-NamingConventions::Capitalization] local_lexical_variable_exemptions=.*_NFA.* .*NFA_.* .*AHFA_.* file_lexical_variable_exemptions=.*SGML_.* subroutine_exemptions=.*_NFA.* .*_AHFA.* Marpa::.* .*_CHAF.* severity=5 [NamingConventions::ProhibitAmbiguousNames] severity=5 forbid = last left right no abstract contract record second close # set is OK -- as in earley set [References::ProhibitDoubleSigils] severity=5 [RegularExpressions::ProhibitCaptureWithoutTest] severity=5 [RegularExpressions::ProhibitComplexRegexes] severity=5 [RegularExpressions::ProhibitEnumeratedClasses] severity=5 [RegularExpressions::ProhibitEscapedMetacharacters] severity=5 [RegularExpressions::ProhibitFixedStringMatches] severity=5 [RegularExpressions::ProhibitSingleCharAlternation] severity=5 [RegularExpressions::ProhibitUnusedCapture] severity=5 [RegularExpressions::ProhibitUnusualDelimiters] allow_all_brackets=1 severity=5 [RegularExpressions::RequireBracesForMultiline] severity=5 [RegularExpressions::RequireExtendedFormatting] severity=5 [RegularExpressions::RequireLineBoundaryMatching] severity=5 [Subroutines::ProhibitAmpersandSigils] severity=5 [Subroutines::ProhibitBuiltinHomonyms] severity=5 [-Subroutines::ProhibitExcessComplexity] [Subroutines::ProhibitExplicitReturnUndef] severity=5 [Subroutines::ProhibitManyArgs] severity=5 [Subroutines::ProhibitNestedSubs] severity=5 [Subroutines::ProhibitSubroutinePrototypes] severity=5 [Subroutines::ProtectPrivateSubs] severity=5 [Subroutines::RequireArgUnpacking] severity=5 allow_subscripts = 1 short_subroutine_statements = 3 [Subroutines::RequireFinalReturn] severity=5 terminal_funcs = Marpa::R2::exception [TestingAndDebugging::ProhibitNoStrict] severity=5 allow = refs # I add warnings to the allow line as I need # them. In effect, my policy is the same # as "allow_with_category_restriction = 1", # but forcing myself to add them documents # which ones I use, and provides an additional # level of checking. [TestingAndDebugging::ProhibitNoWarnings] severity=5 allow=qw once recursion [TestingAndDebugging::ProhibitProlongedStrictureOverride] severity=5 [TestingAndDebugging::RequireTestLabels] severity=5 [TestingAndDebugging::RequireUseStrict] severity=5 [TestingAndDebugging::RequireUseWarnings] severity=5 [ValuesAndExpressions::ProhibitCommaSeparatedStatements] severity=5 [-ValuesAndExpressions::ProhibitConstantPragma] [-ValuesAndExpressions::RequireConstantVersion] [ValuesAndExpressions::ProhibitEmptyQuotes] severity=5 [ValuesAndExpressions::ProhibitEscapedCharacters] severity=5 [ValuesAndExpressions::ProhibitImplicitNewlines] severity=5 [ValuesAndExpressions::ProhibitInterpolationOfLiterals] severity=5 [ValuesAndExpressions::ProhibitLeadingZeros] severity=5 # I comment this out because it is # 1.) not a sin I'm prone to # 2.) obvious from the code when it happens, so that # a perlcritic complaint is unneeded. # 3.) necessary to use Data::Dumper [-ValuesAndExpressions::ProhibitLongChainsOfMethodCalls] severity=5 [ValuesAndExpressions::RequireInterpolationOfMetachars] severity=5 # Reluctantly, I've disabled this one. # It is basically a good test, but # as of 2009-12-10 there is a bug where you either # get this warning or a useless "no critic" warning. # # Rewrites to constants are usually # not my preferred solution. # They often make the code more obscure. [-ValuesAndExpressions::ProhibitMagicNumbers] severity=5 allowed_values = -1 0 1 2 3 4 10 [ValuesAndExpressions::ProhibitMismatchedOperators] severity=5 # Just don't agree with this one. # The differences between operators # is obvious to the eye. # And the difference is not an obscure feature # of Perl, but one easy to remember and # important to know. [-ValuesAndExpressions::ProhibitMixedBooleanOperators] severity=5 [ValuesAndExpressions::ProhibitNoisyQuotes] severity=5 [ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters] severity=5 [ValuesAndExpressions::ProhibitVersionStrings] severity=5 [ValuesAndExpressions::RequireInterpolationOfMetachars] severity=5 [ValuesAndExpressions::RequireNumberSeparators] severity=5 [ValuesAndExpressions::RequireQuotedHeredocTerminator] severity=5 [ValuesAndExpressions::RequireUpperCaseHeredocTerminator] severity=5 [Variables::ProhibitConditionalDeclarations] severity=5 [Variables::ProhibitLocalVars] severity=5 [Variables::ProhibitMatchVars] severity=5 [Variables::ProhibitPackageVars] severity=5 add_packages = DynaLoader Marpa::R2::Context [Variables::ProhibitPerl4PackageNames] severity=5 [Variables::ProhibitPunctuationVars] severity=5 [Variables::ProtectPrivateVars] severity=5 [Variables::RequireInitializationForLocalVars] severity=5 [Variables::RequireLexicalLoopIterators] severity=5 [Variables::RequireLocalizedPunctuationVars] severity=5 [Variables::RequireNegativeIndices] severity=5 [-Subroutines::ProhibitCallsToUnexportedSubs] [-Subroutines::ProhibitQualifiedSubDeclarations] [Subroutines::ProhibitCallsToUndeclaredSubs] severity=5 [-Modules::RequireExplicitInclusion] [Documentation::PodSpelling] severity=5 stop_words_file = author.t/spelling_exceptions.list Marpa-R2-2.086000~dfsg/author.t/meta_yaml.t0000444000000000000000000000150612342464707016744 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use Test::More; use Test::CPAN::Meta; Test::CPAN::Meta::meta_yaml_ok(); Marpa-R2-2.086000~dfsg/author.t/tidy.t0000444000000000000000000000253112342464707015744 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Fatal qw( open close ); use Carp; use Perl::Critic; use Test::Perl::Critic; use Test::More; # Test that the module passes perlcritic BEGIN { $OUTPUT_AUTOFLUSH = 1; } open my $critic_list, '<', 'author.t/critic.list'; my @test_files = <$critic_list>; close $critic_list; chomp @test_files; my $rcfile = File::Spec->catfile( 'author.t', 'perlcriticrc' ); Test::Perl::Critic->import( -verbose => '%l:%c %p %r', -profile => $rcfile, '-single-policy' => 'CodeLayout::RequireTidyCode', ); Test::Perl::Critic::all_critic_ok(@test_files); Marpa-R2-2.086000~dfsg/author.t/perltidyrc0000444000000000000000000000157112342464706016714 0ustar rootroot-l=78 # Max line width is 78 cols -i=4 # Indent level is 4 cols -ci=4 # Continuation indent is 4 cols -st # Output to STDOUT -se # Errors to STDERR -vt=2 # Maximum vertical tightness -cti=0 # No extra indentation for closing brackets -pt=1 # Medium parenthesis tightness -bt=1 # Medium brace tightness -sbt=1 # Medium square bracket tightness -bbt=1 # Medium block brace tightness -nsfs # No space before semicolons -nola # Don't outdent labels -nolq # Don't outdent long quoted strings -hsc # hanging side comments -nolc # Don't outdent long comments -isbc # Indent spaced block comments -csc # Add closing side comments -cscb # Balanced closing side comments -csct=50 # Max length of closing side comment is 50 chars -wbb="% + - * / x != == >= <= =~ !~ < > | & **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" # Break before all operators Marpa-R2-2.086000~dfsg/author.t/accept_tidy0000555000000000000000000000012112342464707017015 0ustar rootroot#!/bin/sh TMP=/tmp/tidy.$$ perltidy --profile=perltidyrc $1 > $TMP mv -i $TMP $1 Marpa-R2-2.086000~dfsg/author.t/pod.t0000444000000000000000000000326112342464706015555 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Fatal qw( open close ); use Carp; use Pod::Simple; use Test::Pod; use Test::More; # Test that the module passes perlcritic BEGIN { $OUTPUT_AUTOFLUSH = 1; } my %exclude = map { ( $_, 1 ) } qw( inc/Test/Weaken.pm ); open my $manifest, '<', 'MANIFEST' or Marpa::R2::exception("open of MANIFEST failed: $ERRNO"); my @test_files = (); FILE: while ( my $file = <$manifest> ) { chomp $file; $file =~ s/\s*[#].*\z//xms; next FILE if -d $file; next FILE if $exclude{$file}; my ($ext) = $file =~ / [.] ([^.]+) \z /xms; next FILE if not defined $ext; $ext = lc $ext; given ($ext) { when ('pl') { push @test_files, $file } when ('pod') { push @test_files, $file } when ('t') { push @test_files, $file } when ('pm') { push @test_files, $file } } ## end given } # FILE close $manifest; Test::Pod::all_pod_files_ok(@test_files); 1; Marpa-R2-2.086000~dfsg/author.t/critic.t0000444000000000000000000000252712342464707016255 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Fatal qw( open close ); use Carp; use Perl::Critic; use Test::Perl::Critic; use Test::More; # Test that the module passes perlcritic BEGIN { $OUTPUT_AUTOFLUSH = 1; } open my $critic_list, '<', 'author.t/critic.list'; my @test_files = <$critic_list>; close $critic_list; chomp @test_files; my $rcfile = File::Spec->catfile( 'author.t', 'perlcriticrc' ); Test::Perl::Critic->import( -verbose => '%l:%c %p %r', -profile => $rcfile, -exclude => [ 'Dynamic::*', 'CodeLayout::RequireTidyCode' ], ); Test::Perl::Critic::all_critic_ok(@test_files); 1; Marpa-R2-2.086000~dfsg/author.t/tidy10000555000000000000000000000007012342464706015561 0ustar rootroot#!/bin/sh perltidy --profile=perltidyrc $1 | diff $1 - Marpa-R2-2.086000~dfsg/author.t/.gitignore0000444000000000000000000000007012342464706016571 0ustar rootrootall.errs critic.errs critic.list display.errs tidy.errs Marpa-R2-2.086000~dfsg/author.t/display.t0000444000000000000000000002107412342464706016442 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Fatal qw(open close); use Text::Diff; use Getopt::Long qw(GetOptions); use List::Util; use Test::More 0.94; use Carp; use Perl::Tidy; use Text::Wrap; use lib 'inc'; use Marpa::R2::Display; my $warnings = 0; my $options_result = GetOptions( 'warnings' => \$warnings ); Marpa::R2::exception("$PROGRAM_NAME options parsing failed") if not $options_result; my %exclude = map { ( $_, 1 ) } qw(); my @additional_files = qw(); my @test_files = @ARGV; my $debug_mode = scalar @test_files; if ( not $debug_mode ) { for my $additional_file (@additional_files) { Test::More::diag("Adding $additional_file"); push @test_files, $additional_file; } open my $manifest, '<', 'MANIFEST' or Marpa::R2::exception("Cannot open MANIFEST: $ERRNO"); FILE: while ( my $file = <$manifest> ) { chomp $file; $file =~ s/\s*[#].*\z//xms; next FILE if $file =~ m( [/] old_pod [/] )xms; next FILE if $file =~ m( html [/] etc [/] drafts [/] )xms; my ($ext) = $file =~ / [.] ([^.]+) \z /xms; next FILE if not defined $ext; $ext = lc $ext; next FILE if $ext ne 'pod' and $ext ne 'pl' and $ext ne 'pm' and $ext ne 't'; push @test_files, $file; } # FILE close $manifest; my %file_seen = (); FILE: for my $test_file (@test_files) { next FILE if $exclude{$test_file}; next FILE if -d $test_file; if ( $file_seen{$test_file}++ ) { Test::More::diag("Duplicate file: $test_file"); } } ## end for my $test_file (@test_files) @test_files = keys %file_seen; } ## end if ( not $debug_mode ) my $error_file; ## no critic (InputOutput::RequireBriefOpen) if ($debug_mode) { open $error_file, '>&STDOUT' or Marpa::R2::exception("Cannot dup STDOUT: $ERRNO"); } else { open $error_file, '>', 'author.t/display.errs' or Marpa::R2::exception("Cannot open display.errs: $ERRNO"); } ## use critic my $display_data = Marpa::R2::Display->new(); FILE: for my $file (@test_files) { if ( not -f $file ) { Test::More::fail(qq{"$file" is not a file}); next FILE; } $display_data->read($file); } ## end for my $file (@test_files) my @formatting_instructions = qw(perltidy remove-display-indent remove-blank-last-line inline partial flatten normalize-whitespace); sub format_display { my ( $text, $instructions, $is_copy ) = @_; my $result = ${$text}; if ( $instructions->{'remove-display-indent'} and $is_copy ) { my ($first_line_spaces) = ( $result =~ /^ (\s+) \S/xms ); $first_line_spaces = quotemeta $first_line_spaces; $result =~ s/^$first_line_spaces//gxms; } if ( $instructions->{'inline'} ) { my $min_indent = 99_999_999; my @text = grep {/ [^ ] /xms} split /\n/xms, $result; for my $line (@text) { my ($s) = ( $line =~ / \A ([ ]* ) /xms ); my $indent = length $s; $min_indent > $indent and $min_indent = $indent; } $result = join "\n", map { substr $_, $min_indent } @text; my $tidied; # perltidy options chosen to make it as likely # as possible that code which differs # only in whitespace # will end up the same. Perl::Tidy::perltidy( source => \$result, destination => \$tidied, perltidyrc => \'-sbt=0 -iob -dcsc -sil=0', ); $result = $tidied; } ## end if ( $instructions->{'inline'} ) if ( $instructions->{'remove-blank-last-line'} ) { $result =~ s/^[ \t]*\n\z//xms; } if ( $instructions->{'flatten'} ) { $result =~ s/[\n\r]/ /gxms; } if ( $instructions->{'normalize-whitespace'} ) { $result =~ s/^\s+//gxms; $result =~ s/\s+$//gxms; $result =~ s/[ \f\t]+/ /gxms; $result =~ s/\n+/\n/gxms; } ## end if ( $instructions->{'normalize-whitespace'} ) if ( defined( my $tidy_options = $instructions->{'perltidy'} ) ) { my $tidied; Perl::Tidy::perltidy( source => \$result, destination => \$tidied, perltidyrc => \$tidy_options ); $result = $tidied; } ## end if ( defined( my $tidy_options = $instructions->{'perltidy'...})) return \$result; } ## end sub format_display # reformat two display according to the instructions in the # second, and compare. sub compare { my ( $original, $copy ) = @_; my $formatted_original = format_display( \$original->{content}, $copy, 0 ); my $formatted_copy = format_display( \$copy->{content}, $copy, 1 ); if ( $copy->{partial} ) { return 1 if -1 != index ${$formatted_original}, ${$formatted_copy}; Test::More::diag( "Partial: ", $original->{filename}, ' vs. ', $copy->{filename}, "\n", ( Text::Diff::diff $formatted_original, $formatted_copy, { STYLE => 'Table' } ) # Text::Wrap::wrap( q{ }, q{ }, ${$formatted_copy} ), # "\nOriginal:\n", # Text::Wrap::wrap( q{ }, q{ }, ${$formatted_original} ) ); return 0; } ## end if ( $copy->{partial} ) return 1 if ${$formatted_original} eq ${$formatted_copy}; Test::More::diag( 'Differences: ', $original->{filename}, ' vs. ', $copy->{filename}, "\n", ( Text::Diff::diff $formatted_original, $formatted_copy, { STYLE => 'Table' } ) ); return 0; } ## end sub compare my $tests_run = 0; my $displays_by_name = $display_data->{displays}; DISPLAY_NAME: for my $display_name ( keys %{$displays_by_name} ) { my $displays = $displays_by_name->{$display_name}; if ( scalar @{$displays} <= 1 ) { Test::More::fail( qq{Display "$display_name" has only one instance, in file } . $displays->[0]->{filename} ); $tests_run++; } ## end if ( scalar @{$displays} <= 1 ) # find the "original" my $original_ix; DISPLAY: for my $display_ix ( 0 .. $#{$displays} ) { if (not grep { $_ ~~ \@formatting_instructions } keys %{ $displays->[$display_ix] } ) { $original_ix = $display_ix; } ## end if ( not grep { $_ ~~ \@formatting_instructions } keys...) } ## end for my $display_ix ( 0 .. $#{$displays} ) # Warn if there wasn't a clear original? $original_ix //= 0; # default to the first DISPLAY: for my $copy_ix ( 0 .. $#{$displays} ) { next DISPLAY if $copy_ix == $original_ix; Test::More::ok compare( $displays->[$original_ix], $displays->[$copy_ix] ), "$display_name, copy $copy_ix"; $tests_run++; } ## end for my $copy_ix ( 0 .. $#{$displays} ) } ## end for my $display_name ( keys %{$displays_by_name} ) my $verbatim_by_file = $display_data->{verbatim_lines}; VERBATIM_FILE: for my $verbatim_file ( keys %{$verbatim_by_file} ) { my @unchecked = (); my $verbatim_lines = $verbatim_by_file->{$verbatim_file}; for my $verbatim_line_number ( 1 .. $#{$verbatim_lines} ) { my $verbatim_line = $verbatim_lines->[$verbatim_line_number]; if ($verbatim_line) { push @unchecked, "$verbatim_line_number: $verbatim_line"; } } ## end for my $verbatim_line_number ( 1 .. $#{$verbatim_lines...}) next VERBATIM_FILE if not @unchecked; Test::More::fail( qq{Verbatim line(s) not checked in "$verbatim_file": } . ( scalar @unchecked ) . " lines\n" . ( join "\n", @unchecked ) ); $tests_run++; } ## end for my $verbatim_file ( keys %{$verbatim_by_file} ) Test::More::done_testing($tests_run); __END__ # vim: set expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/0000755000000000000000000000000012342464706013610 5ustar rootrootMarpa-R2-2.086000~dfsg/lib/Marpa/0000755000000000000000000000000012342464707014651 5ustar rootrootMarpa-R2-2.086000~dfsg/lib/Marpa/R2.pm0000444000000000000000000001477212342464707015503 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2; use 5.010; use strict; use warnings; use vars qw($VERSION $STRING_VERSION @ISA $DEBUG); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic $DEBUG = 0; use Carp; use English qw( -no_match_vars ); use Marpa::R2::Version; $Marpa::R2::USING_XS = 1; $Marpa::R2::USING_PP = 0; $Marpa::R2::LIBMARPA_FILE = '[built-in]'; LOAD_EXPLICIT_LIBRARY: { last LOAD_EXPLICIT_LIBRARY if not $ENV{'MARPA_AUTHOR_TEST'}; my $file = $ENV{MARPA_LIBRARY}; last LOAD_EXPLICIT_LIBRARY if not $file; require DynaLoader; package DynaLoader; my $bs = $file; $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library if (-s $bs) { # only read file if it's not empty # print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug; eval { do $bs; }; warn "$bs: $@\n" if $@; } my $bootname = "marpa_g_new"; @DynaLoader::dl_require_symbols = ($bootname); my $libref = dl_load_file($file, 0) or do { require Carp; Carp::croak("Can't load libmarpa library: '$file'" . dl_error()); }; push(@DynaLoader::dl_librefs,$libref); # record loaded object my @unresolved = dl_undef_symbols(); if (@unresolved) { require Carp; Carp::carp("Undefined symbols present after loading $file: @unresolved\n"); } dl_find_symbol($libref, $bootname) or do { require Carp; Carp::croak("Can't find '$bootname' symbol in $file\n"); }; push(@DynaLoader::dl_shared_objects, $file); # record files loaded $Marpa::R2::LIBMARPA_FILE = $file; } eval { require XSLoader; XSLoader::load( 'Marpa::R2', $Marpa::R2::STRING_VERSION ); 1; } or eval { require DynaLoader; ## no critic(ClassHierarchies::ProhibitExplicitISA) push @ISA, 'DynaLoader'; Dynaloader::bootstrap Marpa::R2 $Marpa::R2::STRING_VERSION; 1; } or Carp::croak("Could not load XS version of Marpa::R2: $EVAL_ERROR"); if ( not $ENV{'MARPA_AUTHOR_TEST'} ) { $Marpa::R2::DEBUG = 0; } else { Marpa::R2::Thin::debug_level_set(1); $Marpa::R2::DEBUG = 1; } sub version_ok { my ($sub_module_version) = @_; return 'not defined' if not defined $sub_module_version; return "$sub_module_version does not match Marpa::R2::VERSION " . $VERSION if $sub_module_version != $VERSION; return; } ## end sub version_ok # Set up the error values my @error_names = Marpa::R2::Thin::error_names(); for ( my $error = 0; $error <= $#error_names; ) { my $current_error = $error; (my $name = $error_names[$error] ) =~ s/\A MARPA_ERR_//xms; no strict 'refs'; *{ "Marpa::R2::Error::$name" } = \$current_error; # This shuts up the "used only once" warning my $dummy = eval q{$} . 'Marpa::R2::Error::' . $name; $error++; } my $version_result; require Marpa::R2::Internal; ( $version_result = version_ok($Marpa::R2::Internal::VERSION) ) and die 'Marpa::R2::Internal::VERSION ', $version_result; require Marpa::R2::Grammar; ( $version_result = version_ok($Marpa::R2::Grammar::VERSION) ) and die 'Marpa::R2::Grammar::VERSION ', $version_result; require Marpa::R2::Recognizer; ( $version_result = version_ok($Marpa::R2::Recognizer::VERSION) ) and die 'Marpa::R2::Recognizer::VERSION ', $version_result; require Marpa::R2::Value; ( $version_result = version_ok($Marpa::R2::Value::VERSION) ) and die 'Marpa::R2::Value::VERSION ', $version_result; require Marpa::R2::MetaG; ( $version_result = version_ok($Marpa::R2::MetaG::VERSION) ) and die 'Marpa::R2::MetaG::VERSION ', $version_result; require Marpa::R2::SLG; ( $version_result = version_ok($Marpa::R2::Scanless::G::VERSION) ) and die 'Marpa::R2::Scanless::G::VERSION ', $version_result; require Marpa::R2::SLR; ( $version_result = version_ok($Marpa::R2::Scanless::R::VERSION) ) and die 'Marpa::R2::Scanless::R::VERSION ', $version_result; require Marpa::R2::MetaAST; ( $version_result = version_ok($Marpa::R2::MetaAST::VERSION) ) and die 'Marpa::R2::MetaAST::VERSION ', $version_result; require Marpa::R2::Stuifzand; ( $version_result = version_ok($Marpa::R2::Stuifzand::VERSION) ) and die 'Marpa::R2::Stuifzand::VERSION ', $version_result; require Marpa::R2::ASF; ( $version_result = version_ok($Marpa::R2::ASF::VERSION) ) and die 'Marpa::R2::ASF::VERSION ', $version_result; sub Marpa::R2::exception { my $exception = join q{}, @_; $exception =~ s/ \n* \z /\n/xms; die($exception) if $Marpa::R2::JUST_DIE; CALLER: for ( my $i = 0; 1; $i++) { my ($package ) = caller($i); last CALLER if not $package; last CALLER if not 'Marpa::R2::' eq substr $package, 0, 11; $Carp::Internal{ $package } = 1; } Carp::croak($exception, q{Marpa::R2 exception}); } package Marpa::R2::Internal::X; use overload ( q{""} => sub { my ($self) = @_; return $self->{message} // $self->{fallback_message}; }, fallback => 1 ); sub new { my ( $class, @hash_ref_args ) = @_; my %x_object = (); for my $hash_ref_arg (@hash_ref_args) { if ( ref $hash_ref_arg ne "HASH" ) { my $ref_type = ref $hash_ref_arg; my $ref_desc = $ref_type ? "ref to $ref_type" : "not a ref"; die "Internal error: args to Marpa::R2::Internal::X->new is $ref_desc -- it should be hash ref"; } ## end if ( ref $hash_ref_arg ne "HASH" ) $x_object{$_} = $hash_ref_arg->{$_} for keys %{$hash_ref_arg}; } ## end for my $hash_ref_arg (@hash_ref_args) my $name = $x_object{name}; die("Internal error: an excepion must have a name") if not $name; $x_object{fallback_message} = qq{Exception "$name" thrown}; return bless \%x_object, $class; } ## end sub new sub name { my ($self) = @_; return $self->{name}; } 1; # vim: set expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/0000755000000000000000000000000012342464707015134 5ustar rootrootMarpa-R2-2.086000~dfsg/lib/Marpa/R2/ASF.pm0000444000000000000000000021140112342464706016077 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::ASF; use 5.010; use strict; use warnings; no warnings qw(recursion); use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic(BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic # The code in this file, for now, breaks "the rules". It makes use # of internal methods not documented as part of Libmarpa. # It is intended to create documented Libmarpa methods to underlie # this interface, and rewrite it to use them package Marpa::R2::Internal::ASF; # This is more complicated that it needs to be for the current implementation. # It allows for LHS terminals (implemented in Libmarpa but not allowed by the SLIF). # It also assumes that every or-node which can be constructed from preceding or-nodes # and the input will be present. This is currently the case, but in the future # rules and/or symbols may have extra-syntactic conditions attached making this # assumption false. # Terms: # NID (Node ID): Encoded ID of either an or-node or an and-node. # # Extensions: # Set "powers": A set of power 0 is an "atom" -- a single NID. # A set of power 1 is a set of NID's -- a nidset. # A set of power 2 is a set of sets of NID's, also called a powerset. # A set of power 3 is a set of powersets, etc. # # The whole ID of NID is the external rule id of an or-node, or -1 # if the NID is for a token and-node. # # Intensions: # A Symch is a nidset, where all the NID's share the same "whole ID" # and the same span. NID's in a symch may differ in their internal rule, # or have different causes. If the symch contains and-node NID's they # will all have the same symbol. # # A choicepoint is a powerset -- a set of symches all of which share # the same set of predecessors. (This set of predecessors is a power 3 set of # choicepoints.) All symches in a choicepoint also share the same span, # and the same symch-symbol. A symch's symbol is the LHS of the rule, # or the symbol of the token in the token and-nodes. sub intset_id { my ( $asf, @ids ) = @_; my $key = join q{ }, sort { $a <=> $b } @ids; my $intset_by_key = $asf->[Marpa::R2::Internal::ASF::INTSET_BY_KEY]; my $intset_id = $intset_by_key->{$key}; return $intset_id if defined $intset_id; $intset_id = $asf->[Marpa::R2::Internal::ASF::NEXT_INTSET_ID]++; $intset_by_key->{$key} = $intset_id; return $intset_id; } ## end sub intset_id sub Marpa::R2::Nidset::obtain { my ( $class, $asf, @nids ) = @_; my $id = intset_id( $asf, @nids ); my $nidset_by_id = $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID]; my $nidset = $nidset_by_id->[$id]; return $nidset if defined $nidset; $nidset = bless [], $class; $nidset->[Marpa::R2::Internal::Nidset::ID] = $id; $nidset->[Marpa::R2::Internal::Nidset::NIDS] = [ sort { $a <=> $b } @nids ]; $nidset_by_id->[$id] = $nidset; return $nidset; } ## end sub Marpa::R2::Nidset::obtain sub Marpa::R2::Nidset::nids { my ($nidset) = @_; return $nidset->[Marpa::R2::Internal::Nidset::NIDS]; } sub Marpa::R2::Nidset::nid { my ( $nidset, $ix ) = @_; return $nidset->[Marpa::R2::Internal::Nidset::NIDS]->[$ix]; } sub Marpa::R2::Nidset::count { my ($nidset) = @_; return scalar @{ $nidset->[Marpa::R2::Internal::Nidset::NIDS] }; } sub Marpa::R2::Nidset::id { my ($nidset) = @_; return $nidset->[Marpa::R2::Internal::Nidset::ID]; } sub Marpa::R2::Nidset::show { my ($nidset) = @_; my $id = $nidset->id(); my $nids = $nidset->nids(); return "Nidset #$id: " . join q{ }, @{$nids}; } ## end sub Marpa::R2::Nidset::show sub Marpa::R2::Powerset::obtain { my ( $class, $asf, @nidset_ids ) = @_; my $id = intset_id( $asf, @nidset_ids ); my $powerset_by_id = $asf->[Marpa::R2::Internal::ASF::POWERSET_BY_ID]; my $powerset = $powerset_by_id->[$id]; return $powerset if defined $powerset; $powerset = bless [], $class; $powerset->[Marpa::R2::Internal::Powerset::ID] = $id; $powerset->[Marpa::R2::Internal::Powerset::NIDSET_IDS] = [ sort { $a <=> $b } @nidset_ids ]; $powerset_by_id->[$id] = $powerset; return $powerset; } ## end sub Marpa::R2::Powerset::obtain sub Marpa::R2::Powerset::nidset_ids { my ($powerset) = @_; return $powerset->[Marpa::R2::Internal::Powerset::NIDSET_IDS]; } sub Marpa::R2::Powerset::count { my ($powerset) = @_; return scalar @{ $powerset->[Marpa::R2::Internal::Powerset::NIDSET_IDS] }; } sub Marpa::R2::Powerset::nidset_id { my ( $powerset, $ix ) = @_; my $nidset_ids = $powerset->[Marpa::R2::Internal::Powerset::NIDSET_IDS]; return if $ix > $#{$nidset_ids}; return $powerset->[Marpa::R2::Internal::Powerset::NIDSET_IDS]->[$ix]; } ## end sub Marpa::R2::Powerset::nidset_id sub Marpa::R2::Powerset::nidset { my ( $powerset, $asf, $ix ) = @_; my $nidset_ids = $powerset->[Marpa::R2::Internal::Powerset::NIDSET_IDS]; return if $ix > $#{$nidset_ids}; my $nidset_id = $powerset->[Marpa::R2::Internal::Powerset::NIDSET_IDS]->[$ix]; my $nidset_by_id = $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID]; return $nidset_by_id->[$nidset_id]; } ## end sub Marpa::R2::Powerset::nidset_id sub Marpa::R2::Powerset::id { my ($powerset) = @_; return $powerset->[Marpa::R2::Internal::Powerset::ID]; } sub Marpa::R2::Powerset::show { my ($powerset) = @_; my $id = $powerset->id(); my $nidset_ids = $powerset->nidset_ids(); return "Powerset #$id: " . join q{ }, @{$nidset_ids}; } ## end sub Marpa::R2::Powerset::show sub set_last_choice { my ( $asf, $nook ) = @_; my $or_nodes = $asf->[Marpa::R2::Internal::ASF::OR_NODES]; my $or_node_id = $nook->[Marpa::R2::Internal::Nook::OR_NODE]; my $and_nodes = $or_nodes->[$or_node_id]; my $choice = $nook->[Marpa::R2::Internal::Nook::FIRST_CHOICE]; return if $choice > $#{$and_nodes}; if ( nook_has_semantic_cause( $asf, $nook ) ) { my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $and_node_id = $and_nodes->[$choice]; my $current_predecessor = $bocage->_marpa_b_and_node_predecessor($and_node_id) // -1; AND_NODE: while (1) { $choice++; $and_node_id = $and_nodes->[$choice]; last AND_NODE if not defined $and_node_id; my $next_predecessor = $bocage->_marpa_b_and_node_predecessor($and_node_id) // -1; last AND_NODE if $current_predecessor != $next_predecessor; } ## end AND_NODE: while (1) $choice--; } ## end if ( nook_has_semantic_cause( $asf, $nook ) ) $nook->[Marpa::R2::Internal::Nook::LAST_CHOICE] = $choice; return $choice; } ## end sub set_last_choice sub nook_new { my ( $asf, $or_node_id, $parent_or_node_id ) = @_; my $nook = []; $nook->[Marpa::R2::Internal::Nook::OR_NODE] = $or_node_id; $nook->[Marpa::R2::Internal::Nook::PARENT] = $parent_or_node_id // -1; $nook->[Marpa::R2::Internal::Nook::FIRST_CHOICE] = 0; set_last_choice( $asf, $nook ); return $nook; } ## end sub nook_new sub nook_increment { my ( $asf, $nook ) = @_; $nook->[Marpa::R2::Internal::Nook::LAST_CHOICE] //= 0; $nook->[Marpa::R2::Internal::Nook::FIRST_CHOICE] = $nook->[Marpa::R2::Internal::Nook::LAST_CHOICE] + 1; return if not defined set_last_choice( $asf, $nook ); return 1; } ## end sub nook_increment sub nook_has_semantic_cause { my ( $asf, $nook ) = @_; my $or_node = $nook->[Marpa::R2::Internal::Nook::OR_NODE]; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $irl_id = $bocage->_marpa_b_or_node_irl($or_node); my $predot_position = $bocage->_marpa_b_or_node_position($or_node) - 1; my $predot_isyid = $grammar_c->_marpa_g_irl_rhs( $irl_id, $predot_position ); return $grammar_c->_marpa_g_nsy_is_semantic($predot_isyid); } ## end sub nook_has_semantic_cause # No check for conflicting usage -- value(), asf(), etc. # at this point sub Marpa::R2::ASF::peak { my ($asf) = @_; my $or_nodes = $asf->[Marpa::R2::Internal::ASF::OR_NODES]; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; die 'No Bocage' if not $bocage; my $augment_or_node_id = $bocage->_marpa_b_top_or_node(); my $augment_and_node_id = $or_nodes->[$augment_or_node_id]->[0]; my $start_or_node_id = $bocage->_marpa_b_and_node_cause($augment_and_node_id); my $base_nidset = Marpa::R2::Nidset->obtain( $asf, $start_or_node_id ); my $glade_id = $base_nidset->id(); # Cannot "obtain" the glade if it is not registered $asf->[Marpa::R2::Internal::ASF::GLADES]->[$glade_id] ->[Marpa::R2::Internal::Glade::REGISTERED] = 1; glade_obtain( $asf, $glade_id ); return $glade_id; } ## end sub Marpa::R2::ASF::peak our $NID_LEAF_BASE = -43; # Range from -1 to -42 reserved for special values sub and_node_to_nid { return -$_[0] + $NID_LEAF_BASE; } sub nid_to_and_node { return -$_[0] + $NID_LEAF_BASE; } sub normalize_asf_blessing { my ($name) = @_; $name =~ s/\A \s * //xms; $name =~ s/ \s * \z//xms; $name =~ s/ \s+ / /gxms; $name =~ s/ \W /_/gxms; return $name; } ## end sub normalize_asf_blessing sub Marpa::R2::Internal::ASF::blessings_set { my ( $asf, $default_blessing ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $default_token_blessing_package = $asf->[ Marpa::R2::Internal::ASF::DEFAULT_TOKEN_BLESSING_PACKAGE ]; my $default_rule_blessing_package = $asf->[Marpa::R2::Internal::ASF::DEFAULT_RULE_BLESSING_PACKAGE]; my @rule_blessing = (); my $highest_rule_id = $grammar_c->highest_rule_id(); RULE: for ( my $rule_id = 0; $rule_id <= $highest_rule_id; $rule_id++ ) { my $blessing; my $rule = $rules->[$rule_id]; $blessing = $rule->[Marpa::R2::Internal::Rule::BLESSING] if defined $rule; if ( defined $blessing and q{::} ne substr $blessing, 0, 2 ) { $rule_blessing[$rule_id] = $blessing; next RULE; } my $lhs_id = $grammar_c->rule_lhs($rule_id); my $name = $grammar->symbol_name($lhs_id); $rule_blessing[$rule_id] = join q{::}, $default_rule_blessing_package, normalize_asf_blessing($name); } ## end RULE: for ( my $rule_id = 0; $rule_id <= $highest_rule_id; ...) my @symbol_blessing = (); my $highest_symbol_id = $grammar_c->highest_symbol_id(); SYMBOL: for ( my $symbol_id = 0; $symbol_id <= $highest_symbol_id; $symbol_id++ ) { my $blessing; my $symbol = $symbols->[$symbol_id]; $blessing = $symbol->[Marpa::R2::Internal::Symbol::BLESSING] if defined $symbol; if ( defined $blessing and q{::} ne substr $blessing, 0, 2 ) { $symbol_blessing[$symbol_id] = $blessing; next SYMBOL; } my $name = $grammar->symbol_name($symbol_id); $symbol_blessing[$symbol_id] = join q{::}, $default_token_blessing_package, normalize_asf_blessing($name); } ## end SYMBOL: for ( my $symbol_id = 0; $symbol_id <= $highest_symbol_id...) $asf->[Marpa::R2::Internal::ASF::RULE_BLESSINGS] = \@rule_blessing; $asf->[Marpa::R2::Internal::ASF::SYMBOL_BLESSINGS] = \@symbol_blessing; return $asf; } ## end sub Marpa::R2::Internal::ASF::blessings_set # Returns undef if no parse sub Marpa::R2::ASF::new { my ( $class, @arg_hashes ) = @_; my $asf = bless [], $class; my $slr; for my $arg_hash (@arg_hashes) { ARG: for my $arg ( keys %{$arg_hash} ) { if ( $arg eq 'slr' ) { $asf->[Marpa::R2::Internal::ASF::SLR] = $slr = $arg_hash->{$arg}; next ARG; } if ( $arg eq 'factoring_max' ) { $asf->[Marpa::R2::Internal::ASF::FACTORING_MAX] = $arg_hash->{$arg}; next ARG; } Marpa::R2::exception( qq{Unknown named arg to $asf->new(): "$arg"}); } ## end ARG: for my $arg ( keys %{$arg_hash} ) } ## end for my $arg_hash (@arg_hashes) Marpa::R2::exception( q{The "slr" named argument must be specified with the Marpa::R2::ASF::new method} ) if not defined $slr; $asf->[Marpa::R2::Internal::ASF::SLR] = $slr; $asf->[Marpa::R2::Internal::ASF::FACTORING_MAX] //= 42; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; if ( defined $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE] ) { # If we already in ASF mode, or are in valuation mode, we cannot create an ASF Marpa::R2::exception( "An attempt was made to create an ASF for a SLIF recognizer already in use\n", " The recognizer must be reset first\n", ' The current SLIF recognizer mode is "', $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE], qq{"\n} ); } ## end if ( defined $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE...]) $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE] = 'forest'; ( $asf->[Marpa::R2::Internal::ASF::RULE_RESOLUTIONS], $asf->[Marpa::R2::Internal::ASF::LEXEME_RESOLUTIONS] ) = Marpa::R2::Internal::Value::resolve_recce( $recce, $slr ); $asf->[Marpa::R2::Internal::ASF::SYMCH_BLESSING_PACKAGE] = 'My_Symch'; $asf->[Marpa::R2::Internal::ASF::FACTORING_BLESSING_PACKAGE] = 'My_Factoring'; $asf->[Marpa::R2::Internal::ASF::PROBLEM_BLESSING_PACKAGE] = 'My_Problem'; $asf->[Marpa::R2::Internal::ASF::DEFAULT_RULE_BLESSING_PACKAGE] = 'My_Rule'; $asf->[Marpa::R2::Internal::ASF::DEFAULT_TOKEN_BLESSING_PACKAGE] = 'My_Token'; $asf->[Marpa::R2::Internal::ASF::NEXT_INTSET_ID] = 0; $asf->[Marpa::R2::Internal::ASF::INTSET_BY_KEY] = {}; $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID] = []; $asf->[Marpa::R2::Internal::ASF::POWERSET_BY_ID] = []; $asf->[Marpa::R2::Internal::ASF::GLADES] = []; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $ordering = $recce->[Marpa::R2::Internal::Recognizer::O_C]; if (not $ordering) { if (not $recce->ordering_create()) { Marpa::R2::exception( "Parse failed\n") } $ordering = $recce->[Marpa::R2::Internal::Recognizer::O_C]; } Marpa::R2::exception( "An attempt was make to create an ASF for a null parse\n", " A null parse is a successful parse of a zero-length string\n", " ASF's are not defined for null parses\n" ) if $ordering->is_null(); my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $or_nodes = $asf->[Marpa::R2::Internal::ASF::OR_NODES] = []; use sort 'stable'; OR_NODE: for ( my $or_node_id = 0;; $or_node_id++ ) { my @and_node_ids = $ordering->_marpa_o_or_node_and_node_ids($or_node_id); last OR_NODE if not scalar @and_node_ids; my @sorted_and_node_ids = map { $_->[-1] } sort { $a <=> $b } map { [ ( $bocage->_marpa_b_and_node_predecessor($_) // -1 ), $_ ] } @and_node_ids; $or_nodes->[$or_node_id] = \@and_node_ids; } ## end OR_NODE: for ( my $or_node_id = 0;; $or_node_id++ ) blessings_set($asf); return $asf; } ## end sub Marpa::R2::ASF::new sub Marpa::R2::ASF::glade_is_visited { my ( $asf, $glade_id ) = @_; my $glade = $asf->[Marpa::R2::Internal::ASF::GLADES]->[$glade_id]; return if not $glade; return $glade->[Marpa::R2::Internal::Glade::VISITED]; } ## end sub Marpa::R2::ASF::glade_is_visited sub Marpa::R2::ASF::glade_visited_clear { my ( $asf, $glade_id ) = @_; my $glade_list = defined $glade_id ? [ $asf->[Marpa::R2::Internal::ASF::GLADES]->[$glade_id] ] : $asf->[Marpa::R2::Internal::ASF::GLADES]; $_->[Marpa::R2::Internal::Glade::VISITED] = undef for grep {defined} @{$glade_list}; return; } ## end sub Marpa::R2::ASF::glade_visited_clear sub nid_sort_ix { my ( $asf, $nid ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; if ( $nid >= 0 ) { my $irl_id = $bocage->_marpa_b_or_node_irl($nid); return $grammar_c->_marpa_g_source_xrl($irl_id); } my $and_node_id = nid_to_and_node($nid); my $token_nsy_id = $bocage->_marpa_b_and_node_symbol($and_node_id); my $token_id = $grammar_c->_marpa_g_source_xsy($token_nsy_id); # -2 is reserved for 'end of data' return -$token_id - 3; } ## end sub nid_sort_ix sub Marpa::R2::ASF::grammar { my ($asf) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; return $slg; } ## end sub Marpa::R2::ASF::grammar sub nid_rule_id { my ( $asf, $nid ) = @_; return if $nid < 0; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $irl_id = $bocage->_marpa_b_or_node_irl($nid); my $xrl_id = $grammar_c->_marpa_g_source_xrl($irl_id); return $xrl_id; } sub or_node_es_span { my ( $asf, $choicepoint ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $origin_es = $bocage->_marpa_b_or_node_origin($choicepoint); my $current_es = $bocage->_marpa_b_or_node_set($choicepoint); return $origin_es, $current_es - $origin_es; } ## end sub or_node_es_span sub token_es_span { my ( $asf, $and_node_id ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $predecessor_id = $bocage->_marpa_b_and_node_predecessor($and_node_id); my $parent_or_node_id = $bocage->_marpa_b_and_node_parent($and_node_id); if ( defined $predecessor_id ) { my $origin_es = $bocage->_marpa_b_or_node_set($predecessor_id); my $current_es = $bocage->_marpa_b_or_node_set($parent_or_node_id); return ( $origin_es, $current_es - $origin_es ); } return or_node_es_span( $asf, $parent_or_node_id ); } ## end sub token_es_span sub nid_literal { my ( $asf, $nid ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; if ( $nid <= $NID_LEAF_BASE ) { my $and_node_id = nid_to_and_node($nid); my ( $start, $length ) = token_es_span( $asf, $and_node_id ); return q{} if $length == 0; return $slr->substring( $start, $length ); } ## end if ( $nid <= $NID_LEAF_BASE ) if ( $nid >= 0 ) { return $slr->substring( or_node_es_span( $asf, $nid ) ); } Marpa::R2::exception("No literal for node ID: $nid"); } sub nid_span { my ( $asf, $nid ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; if ( $nid <= $NID_LEAF_BASE ) { my $and_node_id = nid_to_and_node($nid); my ( $start, $length ) = token_es_span( $asf, $and_node_id ); return ($start, 0) if $length == 0; return $slr->es_to_input_span( $start, $length ); } ## end if ( $nid <= $NID_LEAF_BASE ) if ( $nid >= 0 ) { return $slr->es_to_input_span( or_node_es_span( $asf, $nid ) ); } Marpa::R2::exception("No literal for node ID: $nid"); } sub nid_token_id { my ( $asf, $nid ) = @_; return if $nid > $NID_LEAF_BASE; my $and_node_id = nid_to_and_node($nid); my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $token_nsy_id = $bocage->_marpa_b_and_node_symbol($and_node_id); my $token_id = $grammar_c->_marpa_g_source_xsy($token_nsy_id); return $token_id; } sub nid_symbol_id { my ( $asf, $nid ) = @_; my $token_id = nid_token_id($asf, $nid); return $token_id if defined $token_id; Marpa::R2::exception("No symbol ID for node ID: $nid") if $nid < 0; # Not a token, so return the LHS of the rule my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $irl_id = $bocage->_marpa_b_or_node_irl($nid); my $xrl_id = $grammar_c->_marpa_g_source_xrl($irl_id); my $lhs_id = $grammar_c->rule_lhs($xrl_id); return $lhs_id; } sub nid_symbol_name { my ( $asf, $nid ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $symbol_id = nid_symbol_id($asf, $nid); return $grammar->symbol_name($symbol_id); } sub nid_token_name { my ( $asf, $nid ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $token_id = nid_token_id($asf, $nid); return if not defined $token_id; return $grammar->symbol_name($token_id); } # Memoization is heavily used -- it needs to be to keep the worst cases from # going exponential. The need to memoize is the reason for the very heavy use of # hashes. For example, quite often an HOH (hash of hashes) is used where # an HoL (hash of lists) would usually be preferred. But the HOL would leave me # with the problem of having duplicates, which if followed up upon, would make # the algorithm go exponential. # For the "seen" hashes, the intent, in C, is to use a bit vector. Since typically # choicepoints will only use a tiny fraction of the or- and and-node space, I'll create # a per-choicepoint index in the bit vector for each or- and and-node. The index will # per-ASF, and to avoid the overhead of clearing it, it will track, or each node, the # current CP indexing it. It is assumed that the indexes need only remain valid within # the method call that constructs the CPI (choicepoint iterator). sub first_factoring { my ($choicepoint, $nid_of_choicepoint) = @_; # Current NID of current SYMCH # The caller should ensure that we are never called unless the current # NID is for a rule. Marpa::R2::exception( "Internal error: first_factoring() called for negative NID: $nid_of_choicepoint" ) if $nid_of_choicepoint < 0; # Due to skipping, even the top or-node can have no valid choices my $asf = $choicepoint->[Marpa::R2::Internal::Choicepoint::ASF]; my $or_nodes = $asf->[Marpa::R2::Internal::ASF::OR_NODES]; if ( not scalar @{ $or_nodes->[$nid_of_choicepoint] } ) { $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK] = undef; return; } $choicepoint->[Marpa::R2::Internal::Choicepoint::OR_NODE_IN_USE] ->{$nid_of_choicepoint} = 1; my $nook = nook_new( $asf, $nid_of_choicepoint ); $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK] = [$nook]; # Iterate as long as we cannot finish this stack while ( not factoring_finish($choicepoint, $nid_of_choicepoint) ) { return if not factoring_iterate($choicepoint); } return 1; } sub next_factoring { my ($choicepoint, $nid_of_choicepoint) = @_; my $factoring_stack = $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK]; Marpa::R2::exception( 'Attempt to iterate factoring of uninitialized checkpoint') if not $factoring_stack; while ( factoring_iterate($choicepoint) ) { return 1 if factoring_finish($choicepoint, $nid_of_choicepoint); } # Found nothing to iterate return; } sub factoring_iterate { my ($choicepoint) = @_; my $asf = $choicepoint->[Marpa::R2::Internal::Choicepoint::ASF]; my $factoring_stack = $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK]; FIND_NODE_TO_ITERATE: while (1) { if ( not scalar @{$factoring_stack} ) { $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK] = undef; return; } my $top_nook = $factoring_stack->[-1]; if ( nook_increment( $asf, $top_nook ) ) { last FIND_NODE_TO_ITERATE; # in C, a "break" will do this } # Could not iterate # "Dirty" the corresponding bits in the parent and pop this nook my $stack_ix_of_parent_nook = $top_nook->[Marpa::R2::Internal::Nook::PARENT]; if ( $stack_ix_of_parent_nook >= 0 ) { my $parent_nook = $factoring_stack->[$stack_ix_of_parent_nook]; $parent_nook->[Marpa::R2::Internal::Nook::CAUSE_IS_EXPANDED] = 0 if $top_nook->[Marpa::R2::Internal::Nook::IS_CAUSE]; $parent_nook->[Marpa::R2::Internal::Nook::PREDECESSOR_IS_EXPANDED] = 0 if $top_nook->[Marpa::R2::Internal::Nook::IS_PREDECESSOR]; } ## end if ( $stack_ix_of_parent_nook >= 0 ) my $top_or_node = $top_nook->[Marpa::R2::Internal::Nook::OR_NODE]; $choicepoint->[Marpa::R2::Internal::Choicepoint::OR_NODE_IN_USE] ->{$top_or_node} = undef; pop @{$factoring_stack}; } ## end FIND_NODE_TO_ITERATE: while (1) return 1; } ## end sub factoring_iterate sub factoring_finish { my ($choicepoint, $nid_of_choicepoint) = @_; my $asf = $choicepoint->[Marpa::R2::Internal::Choicepoint::ASF]; my $or_nodes = $asf->[Marpa::R2::Internal::ASF::OR_NODES]; my $factoring_stack = $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK]; my $nidset_by_id = $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID]; my $powerset_by_id = $asf->[Marpa::R2::Internal::ASF::POWERSET_BY_ID]; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my @worklist = ( 0 .. $#{$factoring_stack} ); DO_WORKLIST: while ( scalar @worklist ) { my $stack_ix_of_work_nook = $worklist[-1]; my $work_nook = $factoring_stack->[$stack_ix_of_work_nook]; my $work_or_node = $work_nook->[Marpa::R2::Internal::Nook::OR_NODE]; my $working_choice = $work_nook->[Marpa::R2::Internal::Nook::FIRST_CHOICE]; my $work_and_node_id = $or_nodes->[$work_or_node]->[$working_choice]; my $child_or_node; my $child_is_cause; my $child_is_predecessor; FIND_CHILD_OR_NODE: { if ( !$work_nook->[Marpa::R2::Internal::Nook::CAUSE_IS_EXPANDED] ) { if ( not nook_has_semantic_cause( $asf, $work_nook ) ) { $child_or_node = $bocage->_marpa_b_and_node_cause($work_and_node_id); $child_is_cause = 1; last FIND_CHILD_OR_NODE; } ## end if ( not nook_has_semantic_cause( $asf, $work_nook )) } ## end if ( !$work_nook->[...]) $work_nook->[Marpa::R2::Internal::Nook::CAUSE_IS_EXPANDED] = 1; if ( !$work_nook ->[Marpa::R2::Internal::Nook::PREDECESSOR_IS_EXPANDED] ) { $child_or_node = $bocage->_marpa_b_and_node_predecessor($work_and_node_id); if ( defined $child_or_node ) { $child_is_predecessor = 1; last FIND_CHILD_OR_NODE; } } ## end if ( !$work_nook->[...]) $work_nook->[Marpa::R2::Internal::Nook::PREDECESSOR_IS_EXPANDED] = 1; pop @worklist; next DO_WORKLIST; } ## end FIND_CHILD_OR_NODE: return 0 if $choicepoint->[Marpa::R2::Internal::Choicepoint::OR_NODE_IN_USE] ->{$child_or_node}; return 0 if not scalar @{ $or_nodes->[$work_or_node] }; my $new_nook = nook_new( $asf, $child_or_node, $stack_ix_of_work_nook ); if ($child_is_cause) { $new_nook->[Marpa::R2::Internal::Nook::IS_CAUSE] = 1; $work_nook->[Marpa::R2::Internal::Nook::CAUSE_IS_EXPANDED] = 1; } if ($child_is_predecessor) { $new_nook->[Marpa::R2::Internal::Nook::IS_PREDECESSOR] = 1; $work_nook->[Marpa::R2::Internal::Nook::PREDECESSOR_IS_EXPANDED] = 1; } push @{$factoring_stack}, $new_nook; push @worklist, $#{$factoring_stack}; } ## end DO_WORKLIST: while ( scalar @worklist ) return 1; } ## end sub factoring_finish sub and_nodes_to_cause_nids { my ( $asf, @and_node_ids ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my %causes = (); for my $and_node_id (@and_node_ids) { my $cause_nid = $bocage->_marpa_b_and_node_cause($and_node_id) // and_node_to_nid($and_node_id); $causes{$cause_nid} = 1; } return [ keys %causes ]; } ## end sub and_nodes_to_cause_nids sub glade_id_factors { my ($choicepoint) = @_; my $asf = $choicepoint->[Marpa::R2::Internal::Choicepoint::ASF]; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $or_nodes = $asf->[Marpa::R2::Internal::ASF::OR_NODES]; my @result; my $factoring_stack = $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK]; return if not $factoring_stack; FACTOR: for ( my $factor_ix = 0; $factor_ix <= $#{$factoring_stack}; $factor_ix++ ) { my $nook = $factoring_stack->[$factor_ix]; next FACTOR if not nook_has_semantic_cause( $asf, $nook ); my $or_node = $nook->[Marpa::R2::Internal::Nook::OR_NODE]; my $and_nodes = $or_nodes->[$or_node]; my $cause_nids = and_nodes_to_cause_nids( $asf, map { $and_nodes->[$_] } ( $nook->[Marpa::R2::Internal::Nook::FIRST_CHOICE] .. $nook->[Marpa::R2::Internal::Nook::LAST_CHOICE] ) ); my $base_nidset = Marpa::R2::Nidset->obtain( $asf, @{$cause_nids} ); my $glade_id = $base_nidset->id(); $asf->[Marpa::R2::Internal::ASF::GLADES]->[$glade_id] ->[Marpa::R2::Internal::Glade::REGISTERED] = 1; push @result, $glade_id; } ## end FACTOR: for ( my $factor_ix = 0; $factor_ix <= $#{...}) return \@result; } ## end sub glade_id_factors sub glade_obtain { my ( $asf, $glade_id ) = @_; my $factoring_max = $asf->[Marpa::R2::Internal::ASF::FACTORING_MAX]; my $glades = $asf->[Marpa::R2::Internal::ASF::GLADES]; my $glade = $glades->[$glade_id]; if ( not defined $glade or not $glade->[Marpa::R2::Internal::Glade::REGISTERED] ) { say Data::Dumper::Dumper($glade); Marpa::R2::exception( "Attempt to use an invalid glade, one whose ID is $glade_id"); } ## end if ( not defined $glade or not $glade->[...]) # Return the glade if it is already set up return $glade if $glade->[Marpa::R2::Internal::Glade::SYMCHES]; my $base_nidset = $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID]->[$glade_id]; my $choicepoint; my $choicepoint_powerset; { my @source_data = (); for my $source_nid ( @{ $base_nidset->nids() } ) { my $sort_ix = nid_sort_ix( $asf, $source_nid ); push @source_data, [ $sort_ix, $source_nid ]; } my @sorted_source_data = sort { $a->[0] <=> $b->[0] } @source_data; my $nid_ix = 0; my ( $sort_ix_of_this_nid, $this_nid ) = @{ $sorted_source_data[ $nid_ix++ ] }; my @nids_with_current_sort_ix = (); my $current_sort_ix = $sort_ix_of_this_nid; my @symch_ids = (); NID: while (1) { if ( $sort_ix_of_this_nid != $current_sort_ix ) { # Currently only whole id break logic my $nidset_for_sort_ix = Marpa::R2::Nidset->obtain( $asf, @nids_with_current_sort_ix ); push @symch_ids, $nidset_for_sort_ix->id(); @nids_with_current_sort_ix = (); $current_sort_ix = $sort_ix_of_this_nid; } ## end if ( $sort_ix_of_this_nid != $current_sort_ix ) last NID if not defined $this_nid; push @nids_with_current_sort_ix, $this_nid; my $sorted_entry = $sorted_source_data[ $nid_ix++ ]; if ( defined $sorted_entry ) { ( $sort_ix_of_this_nid, $this_nid ) = @{$sorted_entry}; next NID; } $this_nid = undef; $sort_ix_of_this_nid = -2; } ## end NID: while (1) $choicepoint_powerset = Marpa::R2::Powerset->obtain( $asf, @symch_ids ); $choicepoint->[Marpa::R2::Internal::Choicepoint::ASF] = $asf; $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK] = undef; } # Check if choicepoint already seen? my @symches = (); my $symch_count = $choicepoint_powerset->count(); SYMCH: for ( my $symch_ix = 0; $symch_ix < $symch_count; $symch_ix++ ) { $choicepoint->[Marpa::R2::Internal::Choicepoint::FACTORING_STACK] = undef; my $symch_nidset = $choicepoint_powerset->nidset($asf, $symch_ix); my $choicepoint_nid = $symch_nidset->nid(0); my $symch_rule_id = nid_rule_id($asf, $choicepoint_nid) // -1; # Initial undef indicates no factorings omitted my @factorings = ( $symch_rule_id, undef ); # For a token # There will not be multiple factorings or nids, # it is assumed, for a token if ( $symch_rule_id < 0 ) { my $base_nidset = Marpa::R2::Nidset->obtain( $asf, $choicepoint_nid ); my $glade_id = $base_nidset->id(); $asf->[Marpa::R2::Internal::ASF::GLADES]->[$glade_id] ->[Marpa::R2::Internal::Glade::REGISTERED] = 1; push @factorings, [$glade_id]; push @symches, \@factorings; next SYMCH; } ## end if ( $symch_rule_id < 0 ) my $symch = $choicepoint_powerset->nidset($asf, $symch_ix); my $nid_count = $symch->count(); my $factorings_omitted; FACTORINGS_LOOP: for ( my $nid_ix = 0; $nid_ix < $nid_count; $nid_ix++ ) { $choicepoint_nid = $symch_nidset->nid($nid_ix); first_factoring($choicepoint, $choicepoint_nid); my $factoring = glade_id_factors($choicepoint); FACTOR: while ( defined $factoring ) { if ( scalar @factorings > $factoring_max ) { # update factorings omitted flag $factorings[1] = 1; last FACTORINGS_LOOP; } my @factoring = (); for ( my $item_ix = $#{$factoring}; $item_ix >= 0; $item_ix-- ) { push @factoring, $factoring->[$item_ix]; } ## end for ( my $item_ix = $#{$factoring}; $item_ix >= 0; ...) push @factorings, \@factoring; next_factoring($choicepoint, $choicepoint_nid); $factoring = glade_id_factors($choicepoint); } ## end FACTOR: while ( defined $factoring ) } ## end FACTORINGS_LOOP: for ( my $nid_ix = 0; $nid_ix < $nid_count; $nid_ix...) push @symches, \@factorings; } ## end SYMCH: for ( my $symch_ix = 0; $symch_ix < $symch_count; ...) $glade->[Marpa::R2::Internal::Glade::SYMCHES] = \@symches; $glade->[Marpa::R2::Internal::Glade::ID] = $glade_id; $asf->[Marpa::R2::Internal::ASF::GLADES]->[$glade_id] = $glade; return $glade; } ## end sub glade_obtain sub Marpa::R2::ASF::glade_symch_count { my ( $asf, $glade_id ) = @_; my $glade = glade_obtain( $asf, $glade_id ); Marpa::R2::exception("No glade found for glade ID $glade_id)") if not defined $glade; return scalar @{ $glade->[Marpa::R2::Internal::Glade::SYMCHES] }; } sub Marpa::R2::ASF::glade_literal { my ( $asf, $glade_id ) = @_; my $nidset_by_id = $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID]; my $nidset = $nidset_by_id->[$glade_id]; Marpa::R2::exception("No glade found for glade ID $glade_id)") if not defined $nidset; my $nid0 = $nidset->nid(0); return nid_literal($asf, $nid0); } ## end sub Marpa::R2::ASF::glade_literal sub Marpa::R2::ASF::glade_span { my ( $asf, $glade_id ) = @_; my $nidset_by_id = $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID]; my $nidset = $nidset_by_id->[$glade_id]; Marpa::R2::exception("No glade found for glade ID $glade_id)") if not defined $nidset; my $nid0 = $nidset->nid(0); return nid_span($asf, $nid0); } sub Marpa::R2::ASF::glade_symbol_id { my ( $asf, $glade_id ) = @_; my $nidset_by_id = $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID]; my $nidset = $nidset_by_id->[$glade_id]; Marpa::R2::exception("No glade found for glade ID $glade_id)") if not defined $nidset; my $nid0 = $nidset->nid(0); return nid_symbol_id($asf, $nid0); } sub Marpa::R2::ASF::symch_rule_id { my ( $asf, $glade_id, $symch_ix ) = @_; my $glade = glade_obtain( $asf, $glade_id ); my $symches = $glade->[Marpa::R2::Internal::Glade::SYMCHES]; return if $symch_ix > $#{$symches}; my ($rule_id) = @{ $symches->[$symch_ix] }; return $rule_id; } ## end sub Marpa::R2::ASF::symch_rule_id sub Marpa::R2::ASF::symch_factoring_count { my ( $asf, $glade_id, $symch_ix ) = @_; my $glade = glade_obtain( $asf, $glade_id ); Marpa::R2::exception("No glade found for glade ID $glade_id)") if not defined $glade; my $symches = $glade->[Marpa::R2::Internal::Glade::SYMCHES]; return if $symch_ix > $#{$symches}; return $#{ $symches->[$symch_ix] } - 1; # length minus 2 } ## end sub Marpa::R2::ASF::symch_factoring_count sub Marpa::R2::ASF::factoring_downglades { my ( $asf, $glade_id, $symch_ix, $factoring_ix ) = @_; my $glade = glade_obtain( $asf, $glade_id ); Marpa::R2::exception("No glade found for glade ID $glade_id)") if not defined $glade; my $symches = $glade->[Marpa::R2::Internal::Glade::SYMCHES]; Marpa::R2::exception("No symch #$symch_ix exists for glade ID $glade_id") if $symch_ix > $#{$symches}; my $symch = $symches->[$symch_ix]; my ( $rule_id, undef, @factorings ) = @{$symch}; Marpa::R2::exception("No downglades for glade ID $glade_id, symch #$symch_ix: it is a token symch") if $rule_id < 0; return if $factoring_ix >= scalar @factorings; my $factoring = $factorings[$factoring_ix]; return $factoring; } sub Marpa::R2::ASF::factoring_symbol_count { my ( $asf, $glade_id, $symch_ix, $factoring_ix ) = @_; my $factoring = $asf->factoring_downglades($glade_id, $symch_ix, $factoring_ix); return if not defined $factoring; return scalar @{$factoring}; } ## end sub Marpa::R2::ASF::factoring_symbol_count sub Marpa::R2::ASF::factor_downglade { my ( $asf, $glade_id, $symch_ix, $factoring_ix, $symbol_ix ) = @_; my $factoring = $asf->factoring_downglades($glade_id, $symch_ix, $factoring_ix); return if not defined $factoring; return $factoring->[$symbol_ix]; } ## end sub Marpa::R2::ASF::factor_downglade sub Marpa::R2::Internal::ASF::ambiguities { my ($asf) = @_; my $peak = $asf->peak(); return Marpa::R2::Internal::ASF::glade_ambiguities( $asf, $peak, [] ); } sub Marpa::R2::Internal::ASF::glade_ambiguities { my ( $asf, $glade, $seen ) = @_; return [] if $seen->[$glade]; # empty on revisit $seen->[$glade] = 1; my $grammar = $asf->grammar(); my $symch_count = $asf->glade_symch_count($glade); if ( $symch_count > 1 ) { my $literal = $asf->glade_literal($glade); my $symbol_id = $asf->glade_symbol_id($glade); my $display_form = $grammar->symbol_display_form($symbol_id); return [ [ 'symch', $glade, ] ]; } ## end if ( $symch_count > 1 ) my $rule_id = $asf->symch_rule_id( $glade, 0 ); return [] if $rule_id < 0; # no ambiguities if a token # ignore any truncation of the factorings my $factoring_count = $asf->symch_factoring_count( $glade, 0 ); if ( $factoring_count <= 1 ) { my $downglades = $asf->factoring_downglades( $glade, 0, 0 ); my @problems = map { @{ glade_ambiguities( $asf, $_, $seen ) } } @{$downglades}; return \@problems; } ## end if ( $factoring_count <= 1 ) my @results = (); my $downglades = $asf->factoring_downglades( $glade, 0, 0 ); my $min_factors = $#{$downglades} + 1; my ( $upglade_start, $upglade_length ) = $asf->glade_span($glade); my $sync_location = $upglade_start + $upglade_length; my @factors_by_factoring = ($downglades); for ( my $factoring_ix = 1; $factoring_ix < $factoring_count; $factoring_ix++ ) { my $downglades = $asf->factoring_downglades( $glade, 0, $factoring_ix ); my $factor_count = $#{$downglades} + 1; $min_factors = $min_factors > $factor_count ? $factor_count : $min_factors; # Determine a first potential # "sync location of the factors" from # the earliest start of the first downglade of any factoring. # Currently this will be the start of the parent glade, but this # method will be safe against any future hacks. my ($this_sync_location) = $asf->glade_span( $downglades->[0] ); $sync_location = List::Util::min( $this_sync_location, $sync_location ); push @factors_by_factoring, $downglades; } ## end for ( my $factoring_ix = 1; $factoring_ix < $factoring_count...) my @factor_ix = (0) x $factoring_count; SYNC_PASS: while (1) { # Assume synced and unambiguous until we see otherwise. my $is_synced = 1; # First find a synch'ed set of factors, if we can FACTORING: for ( my $factoring_ix = 0; $factoring_ix < $factoring_count; $factoring_ix++ ) { my $this_factor_ix = $factor_ix[$factoring_ix]; my $this_downglade = $factors_by_factoring[$factoring_ix][$this_factor_ix]; my ($this_start) = $asf->glade_span($this_downglade); # To keep time complexity down we limit the number of times we deal # with a factoring at a sync location to 3, worst case -- a pass which # identifies it as a potential sync location, a pass which # (if possible) brings all the factors to that location, and a # pass which leaves all factor IX's where they are, and determines # we have found a sync location. This makes out time O(f*n), where # f is the factoring count and n is the mininum number of factors. while ( $this_start < $sync_location ) { $factor_ix[$factoring_ix]++; last SYNC_PASS if $factor_ix[$factoring_ix] >= $min_factors; $this_start = $asf->glade_span($this_downglade); } ## end if ( $this_start < $sync_location ) if ( $this_start > $sync_location ) { $is_synced = 0; $sync_location = $this_start; } } ## end FACTORING: for ( my $factoring_ix = 0; $factoring_ix < ...) next SYNC_PASS if not $is_synced; # If here, every factor starts at the sync location SYNCED_RESULT: { my $ambiguous_factors; my $first_factor_ix = $factor_ix[0]; my $first_downglade = $factors_by_factoring[0][$first_factor_ix]; FACTORING: for ( my $factoring_ix = 1; $factoring_ix < $factoring_count; $factoring_ix++ ) { my $this_factor_ix = $factor_ix[$factoring_ix]; my $this_downglade = $factors_by_factoring[$factoring_ix][$this_factor_ix]; if ( $this_downglade != $first_downglade ) { $ambiguous_factors = [ $first_factor_ix, $factoring_ix, $this_factor_ix ]; last FACTORING; } ## end if ( $this_downglade != $first_downglade ) } ## end FACTORING: for ( my $factoring_ix = 1; $factoring_ix < ...) # If here, all the the downglades are identical if ( not defined $ambiguous_factors ) { push @results, @{ glade_ambiguities( $asf, $first_downglade, $seen ) }; last SYNCED_RESULT; } # First factoring IX is always zero push @results, [ 'factoring', $glade, 0, @{$ambiguous_factors} ]; } ## end SYNCED_RESULT: $factor_ix[$_]++ for 0 .. $factoring_count; last SYNC_PASS if List::Util::max(@factor_ix) >= $min_factors; } ## end SYNC_PASS: while (1) return \@results; } ## end sub Marpa::R2::Internal::ASF::glade_ambiguities # A generic display routine for ambiguities -- complex application will # want to replace this, using it perhaps as a fallback. sub Marpa::R2::Internal::ASF::ambiguities_show { my ( $asf, $ambiguities ) = @_; my $grammar = $asf->grammar(); my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $p_input = $slr->[Marpa::R2::Internal::Scanless::R::P_INPUT_STRING]; my $result = q{}; AMBIGUITY: for my $ambiguity ( @{$ambiguities} ) { my $type = $ambiguity->[0]; if ( $type eq 'symch' ) { # Not tested !!!! my ( undef, $glade ) = @{$ambiguity}; my $symbol_display_form = $grammar->symbol_display_form( $asf->glade_symbol_id($glade) ); my ( $start, $length ) = $asf->glade_span($glade); my ( $start_line, $start_column ) = $slr->line_column($start); my ( $end_line, $end_column ) = $slr->line_column( $start + $length - 1 ); my $display_length = List::Util::min( $length, 60 ); $result .= qq{Ambiguous symch at Glade=$glade, Symbol=<$symbol_display_form>:\n}; $result .= qq{ The ambiguity is from line $start_line, column $start_column } . qq{to line $end_line, column $end_column\n}; my $literal_label = $display_length == $length ? 'Text is: ' : 'Text begins: '; $result .= q{ } . $literal_label . Marpa::R2::Internal::Scanless::input_escape( $p_input, $start, $display_length ) . qq{\n}; my $symch_count = $asf->glade_symch_count($glade); my $display_symch_count = List::Util::min( 5, $symch_count ); $result .= $symch_count == $display_symch_count ? " There are $symch_count symches\n" : " There are $symch_count symches -- showing only the first $display_symch_count\n"; SYMCH_IX: for my $symch_ix ( 0 .. $display_symch_count - 1 ) { my $rule_id = $asf->symch_rule_id( $glade, $symch_ix ); if ( $rule_id < 0 ) { $result .= " Symch $symch_ix is a token\n"; next SYMCH_IX; } $result .= " Symch $symch_ix is a rule: " . $grammar->rule_show($rule_id) . "\n"; } ## end SYMCH_IX: for my $symch_ix ( 0 .. $display_symch_count - 1 ) next AMBIGUITY; } ## end if ( $type eq 'symch' ) if ( $type eq 'factoring' ) { my $factoring_ix1 = 0; my ( undef, $glade, $symch_ix, $factor_ix1, $factoring_ix2, $factor_ix2 ) = @{$ambiguity}; my $first_downglades = $asf->factoring_downglades( $glade, $symch_ix, 0 ); my $first_downglade = $first_downglades->[$factor_ix1]; { my $these_downglades = $asf->factoring_downglades( $glade, $symch_ix, $factoring_ix2 ); my $this_downglade = $these_downglades->[$factor_ix2]; my $symbol_display_form = $grammar->symbol_display_form( $asf->glade_symbol_id($first_downglade) ); my ( $start, $first_length ) = $asf->glade_span($first_downglade); my ( undef, $this_length ) = $asf->glade_span($this_downglade); my ( $start_line, $start_column ) = $slr->line_column($start); my $display_length = List::Util::min( $first_length, $this_length, 60 ); $result .= qq{Length of symbol "$symbol_display_form" at line $start_line, column $start_column is ambiguous\n}; if ( $display_length > 0 ) { $result .= qq{ Choices start with: } . Marpa::R2::Internal::Scanless::input_escape( $p_input, $start, $display_length ) . qq{\n}; } ## end if ( $display_length > 0 ) my @display_downglade = ( $first_downglade, $this_downglade ); DISPLAY_GLADE: for ( my $glade_ix = 0; $glade_ix <= $#display_downglade; $glade_ix++ ) { # Choices may be zero length my $choice_number = $glade_ix + 1; my $glade_id = $display_downglade[$glade_ix]; my ( undef, $length ) = $asf->glade_span($glade_id); if ( $length <= 0 ) { $result .= qq{ Choice $choice_number is zero length\n}; next DISPLAY_GLADE; } my ( $end_line, $end_column ) = $slr->line_column( $start + $length - 1 ); $result .= qq{ Choice $choice_number, length=$length, ends at line $end_line, column $end_column\n}; if ( $length > 60 ) { $result .= qq{ Choice $choice_number ending: } . Marpa::R2::Internal::Scanless::reversed_input_escape( $p_input, $start + $length, 60 ) . qq{\n}; next DISPLAY_GLADE; } ## end if ( $length > 60 ) $result .= qq{ Choice $choice_number: } . Marpa::R2::Internal::Scanless::input_escape( $p_input, $start, $length ) . qq{\n}; } ## end DISPLAY_GLADE: for ( my $glade_ix = 0; $glade_ix <= ...) next AMBIGUITY; } ## end FACTORING: for ( my $factoring_ix = 1; $factoring_ix < ...) next AMBIGUITY; } ## end if ( $type eq 'factoring' ) $result .= qq{Ambiguities of type "$type" not implemented:\n} . Data::Dumper::dumper($ambiguity); next AMBIGUITY; } ## end AMBIGUITY: for my $ambiguity ( @{$ambiguities} ) return $result; } ## end sub Marpa::R2::Internal::ASF::ambiguities_show # The higher level calls sub Marpa::R2::ASF::traverse { my ( $asf, $per_traverse_object, $method ) = @_; if ( ref $method ne 'CODE' ) { Marpa::R2::exception( 'Argument to $asf->traverse() must be an anonymous subroutine'); } if ( not ref $per_traverse_object ) { Marpa::R2::exception( 'Argument to $asf->traverse() must be a reference'); } my $peak = $asf->peak(); my $peak_glade = glade_obtain( $asf, $peak ); my $traverser = bless [], "Marpa::R2::Internal::ASF::Traverse"; $traverser->[Marpa::R2::Internal::ASF::Traverse::ASF] = $asf; $traverser->[Marpa::R2::Internal::ASF::Traverse::CODE] = $method; $traverser->[Marpa::R2::Internal::ASF::Traverse::PER_TRAVERSE_OBJECT] = $per_traverse_object; $traverser->[Marpa::R2::Internal::ASF::Traverse::VALUES] = []; $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE] = $peak_glade; $traverser->[Marpa::R2::Internal::ASF::Traverse::SYMCH_IX] = 0; $traverser->[Marpa::R2::Internal::ASF::Traverse::FACTORING_IX] = 0; return $method->( $traverser, $per_traverse_object ); } ## end sub Marpa::R2::ASF::traverse sub Marpa::R2::Internal::ASF::Traverse::literal { my ( $traverser ) = @_; my $asf = $traverser->[Marpa::R2::Internal::ASF::Traverse::ASF]; my $glade = $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE]; my $glade_id = $glade->[Marpa::R2::Internal::Glade::ID]; return $asf->glade_literal($glade_id); } sub Marpa::R2::Internal::ASF::Traverse::span { my ( $traverser ) = @_; my $asf = $traverser->[Marpa::R2::Internal::ASF::Traverse::ASF]; my $glade = $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE]; my $glade_id = $glade->[Marpa::R2::Internal::Glade::ID]; return $asf->glade_span($glade_id); } sub Marpa::R2::Internal::ASF::Traverse::symbol_id { my ( $traverser ) = @_; my $asf = $traverser->[Marpa::R2::Internal::ASF::Traverse::ASF]; my $glade = $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE]; my $glade_id = $glade->[Marpa::R2::Internal::Glade::ID]; return $asf->glade_symbol_id($glade_id); } sub Marpa::R2::Internal::ASF::Traverse::rule_id { my ( $traverser ) = @_; my $glade = $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE]; my $symch_ix = $traverser->[Marpa::R2::Internal::ASF::Traverse::SYMCH_IX]; my $symch = $glade->[Marpa::R2::Internal::Glade::SYMCHES]->[$symch_ix]; my ( $rule_id ) = @{$symch}; return if $rule_id < 0; return $rule_id; } ## end sub Marpa::R2::Internal::ASF::Traverse::rule_id sub Marpa::R2::Internal::ASF::Traverse::rh_length { my ( $traverser ) = @_; my $glade = $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE]; my $symch_ix = $traverser->[Marpa::R2::Internal::ASF::Traverse::SYMCH_IX]; my $symch = $glade->[Marpa::R2::Internal::Glade::SYMCHES]->[$symch_ix]; my ( $rule_id, undef, @factorings ) = @{$symch}; Marpa::R2::exception( '$glade->rh_length($rh_ix) called for a token -- that is not allowed') if $rule_id < 0; my $factoring_ix = $traverser->[Marpa::R2::Internal::ASF::Traverse::FACTORING_IX]; my $factoring = $factorings[$factoring_ix]; return scalar @{$factoring}; } ## end sub Marpa::R2::Internal::ASF::Traverse::rh_length sub Marpa::R2::Internal::ASF::Traverse::rh_value { my ( $traverser, $rh_ix ) = @_; my $glade = $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE]; my $symch_ix = $traverser->[Marpa::R2::Internal::ASF::Traverse::SYMCH_IX]; my $symch = $glade->[Marpa::R2::Internal::Glade::SYMCHES]->[$symch_ix]; my ( $rule_id, undef, @factorings ) = @{$symch}; Marpa::R2::exception( '$glade->rh_value($rh_ix) called for a token -- that is not allowed') if $rule_id < 0; my $factoring_ix = $traverser->[Marpa::R2::Internal::ASF::Traverse::FACTORING_IX]; my $factoring = $factorings[$factoring_ix]; return if $rh_ix > $#{$factoring}; my $downglade_id = $factoring->[$rh_ix]; my $memoized_value = $traverser->[Marpa::R2::Internal::ASF::Traverse::VALUES]->[$downglade_id]; return $memoized_value if defined $memoized_value; my $asf = $traverser->[Marpa::R2::Internal::ASF::Traverse::ASF]; my $downglade = glade_obtain( $asf, $downglade_id ); my $blessing = ref $traverser; # A shallow clone my $child_traverser = bless [ @{$traverser} ], $blessing; $child_traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE] = $downglade; $child_traverser->[Marpa::R2::Internal::ASF::Traverse::SYMCH_IX] = 0; $child_traverser->[Marpa::R2::Internal::ASF::Traverse::FACTORING_IX] = 0; my $code = $traverser->[Marpa::R2::Internal::ASF::Traverse::CODE]; my $value = $code->( $child_traverser, $traverser->[Marpa::R2::Internal::ASF::Traverse::PER_TRAVERSE_OBJECT] ); Marpa::R2::exception( 'The ASF traversing method returned undef -- that is not allowed') if not defined $value; $traverser->[Marpa::R2::Internal::ASF::Traverse::VALUES]->[$downglade_id] = $value; return $value; } ## end sub Marpa::R2::Internal::ASF::Traverse::rh_value sub Marpa::R2::Internal::ASF::Traverse::rh_values { my ( $traverser ) = @_; return map { Marpa::R2::Internal::ASF::Traverse::rh_value( $traverser, $_ ) } 0 .. Marpa::R2::Internal::ASF::Traverse::rh_length( $traverser ) - 1; } sub Marpa::R2::Internal::ASF::Traverse::next_factoring { my ($traverser) = @_; my $glade = $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE]; my $glade_id = $glade->[Marpa::R2::Internal::Glade::ID]; my $asf = $traverser->[Marpa::R2::Internal::ASF::Traverse::ASF]; my $symch_ix = $traverser->[Marpa::R2::Internal::ASF::Traverse::SYMCH_IX]; my $last_factoring = $asf->symch_factoring_count( $glade_id, $symch_ix ) - 1; my $factoring_ix = $traverser->[Marpa::R2::Internal::ASF::Traverse::FACTORING_IX]; return if $factoring_ix >= $last_factoring; $factoring_ix++; $traverser->[Marpa::R2::Internal::ASF::Traverse::FACTORING_IX] = $factoring_ix; return $factoring_ix; } ## end sub Marpa::R2::Internal::ASF::Traverse::next_factoring sub Marpa::R2::Internal::ASF::Traverse::next_symch { my ($traverser) = @_; my $glade = $traverser->[Marpa::R2::Internal::ASF::Traverse::GLADE]; my $glade_id = $glade->[Marpa::R2::Internal::Glade::ID]; my $asf = $traverser->[Marpa::R2::Internal::ASF::Traverse::ASF]; my $symch_ix = $traverser->[Marpa::R2::Internal::ASF::Traverse::SYMCH_IX]; my $last_symch = $asf->glade_symch_count( $glade_id, $symch_ix ) - 1; return if $symch_ix >= $last_symch; $symch_ix++; $traverser->[Marpa::R2::Internal::ASF::Traverse::SYMCH_IX] = $symch_ix; return $symch_ix; } ## end sub Marpa::R2::Internal::ASF::Traverse::next_symch sub Marpa::R2::Internal::ASF::Traverse::next { my ($traverser) = @_; return $traverser->next_factoring() // $traverser->next_symch(); } # GLADE_SEEN is a local -- this is to silence warnings our %GLADE_SEEN; sub form_choice { my ( $parent_choice, $sub_choice ) = @_; return $sub_choice if not defined $parent_choice; return join q{.}, $parent_choice, $sub_choice; } sub Marpa::R2::ASF::dump_glade { my ( $asf, $glade_id, $parent_choice, $item_ix ) = @_; if ( $GLADE_SEEN{$glade_id} ) { return [ [0, $glade_id, "already displayed"] ]; } $GLADE_SEEN{$glade_id} = 1; my $grammar = $asf->grammar(); my @lines = (); my $symch_indent = 0; my $symch_count = $asf->glade_symch_count($glade_id); my $symch_choice = $parent_choice; if ( $symch_count > 1 ) { $item_ix //= 0; push @lines, [ 0, undef, "Symbol #$item_ix " . $grammar->symbol_display_form($asf->glade_symbol_id($glade_id)) . " has $symch_count symches" ]; $symch_indent += 2; $symch_choice = form_choice( $parent_choice, $item_ix ); } ## end if ( $symch_count > 1 ) for ( my $symch_ix = 0; $symch_ix < $symch_count; $symch_ix++ ) { my $current_choice = $symch_count > 1 ? form_choice( $symch_choice, $symch_ix ) : $symch_choice; my $indent = $symch_indent; if ( $symch_count > 1 ) { push @lines, [ $symch_indent , undef, "Symch #$current_choice" ]; } my $rule_id = $asf->symch_rule_id( $glade_id, $symch_ix ); if ( $rule_id >= 0 ) { push @lines, [ $symch_indent, $glade_id, "Rule $rule_id: " . $grammar->rule_show($rule_id) ]; for my $line ( @{ dump_factorings( $asf, $glade_id, $symch_ix, $current_choice ) } ) { my ( $line_indent, @rest_of_line ) = @{$line}; push @lines, [ $line_indent + $symch_indent + 2, @rest_of_line ]; } ## end for my $line ( dump_factorings( $asf, $glade_id, ...)) } ## end if ( $rule_id >= 0 ) else { my $line = dump_terminal( $asf, $glade_id, $current_choice ); my ( $line_indent, @rest_of_line ) = @{$line}; push @lines, [ $line_indent + $symch_indent, @rest_of_line ]; } ## end else [ if ( $rule_id >= 0 ) ] } ## end for ( my $symch_ix = 0; $symch_ix < $symch_count; $symch_ix...) return \@lines; } # Show all the factorings of a SYMCH sub dump_factorings { my ( $asf, $glade_id, $symch_ix, $parent_choice ) = @_; my @lines; my $factoring_count = $asf->symch_factoring_count( $glade_id, $symch_ix ); for ( my $factoring_ix = 0; $factoring_ix < $factoring_count; $factoring_ix++ ) { my $indent = 0; my $current_choice = $parent_choice; if ( $factoring_count > 1 ) { $indent = 2; $current_choice = form_choice( $parent_choice, $factoring_ix ); push @lines, [ 0, undef, "Factoring #$current_choice" ]; } my $symbol_count = $asf->factoring_symbol_count( $glade_id, $symch_ix, $factoring_ix ); SYMBOL: for my $symbol_ix ( 0 .. $symbol_count - 1 ) { my $downglade = $asf->factor_downglade( $glade_id, $symch_ix, $factoring_ix, $symbol_ix ); for my $line ( @{ $asf->dump_glade( $downglade, $current_choice, $symbol_ix ) } ) { my ( $line_indent, @rest_of_line ) = @{$line}; push @lines, [ $line_indent + $indent, @rest_of_line ]; } ## end for my $line ( @{ $asf->dump_glade( $downglade, ...)}) } ## end SYMBOL: for my $symbol_ix ( 0 .. $symbol_count - 1 ) } ## end for ( my $factoring_ix = 0; $factoring_ix < $factoring_count...) return \@lines; } ## end sub dump_factorings sub dump_terminal { my ( $asf, $glade_id, $symch_ix, $parent_choice ) = @_; # There can only be one symbol in a terminal and therefore only one factoring my $current_choice = $parent_choice; my $literal = $asf->glade_literal($glade_id); my $symbol_id = $asf->glade_symbol_id($glade_id); my $grammar = $asf->grammar(); my $display_form = $grammar->symbol_display_form($symbol_id); return [0, $glade_id, qq{Symbol $display_form: "$literal"}]; } ## end sub dump_terminal sub Marpa::R2::ASF::dump { my ($asf) = @_; my $peak = $asf->peak(); local %GLADE_SEEN = (); ## no critic (Variables::ProhibitLocalVars) my $lines = $asf->dump_glade( $peak ); my $next_sequenced_id = 1; # one-based my %sequenced_id = (); $sequenced_id{$_} //= $next_sequenced_id++ for grep { defined } map { $_->[1] } @{$lines}; my $text = q{}; for my $line ( @{$lines}[ 1 .. $#$lines ] ) { my ( $line_indent, $glade_id, $body ) = @{$line}; $line_indent -= 2; $text .= q{ } x $line_indent; $text .= 'GL' . $sequenced_id{$glade_id} . q{ } if defined $glade_id; $text .= "$body\n"; } return $text; } ## end sub show sub Marpa::R2::ASF::show_nidsets { my ($asf) = @_; my $text = q{}; my $nidsets = $asf->[Marpa::R2::Internal::ASF::NIDSET_BY_ID]; for my $nidset ( grep {defined} @{$nidsets} ) { $text .= $nidset->show() . "\n"; } return $text; } ## end sub Marpa::R2::ASF::show_nidsets sub Marpa::R2::ASF::show_powersets { my ($asf) = @_; my $text = q{}; my $powersets = $asf->[Marpa::R2::Internal::ASF::POWERSET_BY_ID]; for my $powerset ( grep {defined} @{$powersets} ) { $text .= $powerset->show() . "\n"; } return $text; } ## end sub Marpa::R2::ASF::show_powersets sub dump_nook { my ( $asf, $nook ) = @_; my $slr = $asf->[Marpa::R2::Internal::ASF::SLR]; my $or_nodes = $asf->[Marpa::R2::Internal::ASF::OR_NODES]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $or_node_id = $nook->[Marpa::R2::Internal::Nook::OR_NODE]; my $and_node_count = scalar @{ $or_nodes->[$or_node_id] }; my $text = 'Nook '; my @text = (); push @text, $nook->[Marpa::R2::Internal::Nook::IS_CAUSE] ? q{C} : q{-}; push @text, $nook->[Marpa::R2::Internal::Nook::IS_PREDECESSOR] ? q{P} : q{-}; push @text, $nook->[Marpa::R2::Internal::Nook::CAUSE_IS_EXPANDED] ? q{C+} : q{--}; push @text, $nook->[Marpa::R2::Internal::Nook::PREDECESSOR_IS_EXPANDED] ? q{P+} : q{--}; $text .= join q{ }, @text; $text .= ' @' . $nook->[Marpa::R2::Internal::Nook::FIRST_CHOICE] . q{-} . $nook->[Marpa::R2::Internal::Nook::LAST_CHOICE] . qq{ of $and_node_count: }; $text .= $recce->verbose_or_node($or_node_id); return $text; } ## end sub dump_nook # For debugging sub dump_factoring_stack { my ( $asf, $stack ) = @_; my $text = q{}; for ( my $stack_ix = 0; $stack_ix <= $#{$stack}; $stack_ix++ ) { # Nook already has newline at end $text .= "$stack_ix: " . dump_nook( $asf, $stack->[$stack_ix] ); } return $text . "\n"; } ## end sub dump_factoring_stack 1; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/SLG.pm0000444000000000000000000011477612342464706016134 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::Scanless::G; use 5.010; use strict; use warnings; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic(BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic package Marpa::R2::Internal::Scanless::G; use Scalar::Util 'blessed'; use English qw( -no_match_vars ); # names of packages for strings our $PACKAGE = 'Marpa::R2::Scanless::G'; sub Marpa::R2::Internal::Scanless::meta_grammar { my $meta_slg = bless [], 'Marpa::R2::Scanless::G'; state $hashed_metag = Marpa::R2::Internal::MetaG::hashed_grammar(); Marpa::R2::Internal::Scanless::G::hash_to_runtime( $meta_slg, $hashed_metag, { bless_package => 'Marpa::R2::Internal::MetaAST_Nodes' } ); my $thick_g1_grammar = $meta_slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR]; my @mask_by_rule_id; $mask_by_rule_id[$_] = $thick_g1_grammar->_rule_mask($_) for $thick_g1_grammar->rule_ids(); $meta_slg->[Marpa::R2::Internal::Scanless::G::MASK_BY_RULE_ID] = \@mask_by_rule_id; return $meta_slg; } ## end sub Marpa::R2::Internal::Scanless::meta_grammar sub Marpa::R2::Scanless::G::new { my ( $class, @hash_ref_args ) = @_; my $slg = []; bless $slg, $class; my ($dsl, $g1_args) = Marpa::R2::Internal::Scanless::G::set ( $slg, 'new', @hash_ref_args ); my $ast = Marpa::R2::Internal::MetaAST->new( $dsl ); my $hashed_ast = $ast->ast_to_hash(); Marpa::R2::Internal::Scanless::G::hash_to_runtime($slg, $hashed_ast, $g1_args); return $slg; } ## end sub Marpa::R2::Scanless::G::new sub Marpa::R2::Scanless::G::set { my ( $slg, @hash_ref_args ) = @_; Marpa::R2::Internal::Scanless::G::set ( $slg, 'set', @hash_ref_args ); return $slg; } # The context flag indicates whether this ::set() is called directly by the user; # is for the external constructor; or is for the internal ("meta") constructor. # "Context" flags of this kind # are much decried practice, and for good reason, but in this case # I think it is justified. # This logic really needs to be all in one place, and so a flag # to trigger the minor differences needed by the various calling # contexts is a small price to pay. sub Marpa::R2::Internal::Scanless::G::set { my ( $slg, $method, @hash_ref_args ) = @_; # Other possible grammar options: # default_rank # inaccessible_ok # unproductive_ok # warnings state $copy_to_g1_args = { map { ( $_, 1 ); } qw(trace_file_handle action_object default_action bless_package) }; state $set_method_args = { map { ( $_, 1 ); } qw(trace_file_handle trace_terminals) }; state $new_method_args = { map { ( $_, 1 ); } qw(source trace_terminals), keys %{$copy_to_g1_args} }; for my $args (@hash_ref_args) { my $ref_type = ref $args; if ( not $ref_type ) { Marpa::R2::exception( q{$slg->} . $method . qq{() expects args as ref to HASH; got non-reference instead} ); } ## end if ( not $ref_type ) if ( $ref_type ne 'HASH' ) { Marpa::R2::exception( q{$slg->} . $method . qq{() expects args as ref to HASH, got ref to $ref_type instead} ); } ## end if ( $ref_type ne 'HASH' ) } ## end for my $args (@hash_ref_args) my %flat_args = (); for my $hash_ref (@hash_ref_args) { ARG: for my $arg_name ( keys %{$hash_ref} ) { $flat_args{$arg_name} = $hash_ref->{$arg_name}; } } my $ok_args = $set_method_args; $ok_args = $new_method_args if $method eq 'new'; my @bad_args = grep { not $ok_args->{$_} } keys %flat_args; if ( scalar @bad_args ) { Marpa::R2::exception( q{Bad named argument(s) to $slg->} . $method . q{() method: } . join q{ }, @bad_args ); } ## end if ( scalar @bad_args ) my $dsl; if ( $method eq 'new' ) { state $arg_name = 'source'; $dsl = $flat_args{$arg_name}; Marpa::R2::exception( qq{Marpa::R2::Scanless::G::new() called without a "$arg_name" argument} ) if not defined $dsl; my $ref_type = ref $dsl; if ( $ref_type ne 'SCALAR' ) { my $desc = $ref_type ? "a ref to $ref_type" : 'not a ref'; Marpa::R2::exception( qq{'$arg_name' name argument to Marpa::R2::Scanless::G->new() is $desc\n}, " It should be a ref to a string\n" ); } ## end if ( $ref_type ne 'SCALAR' ) if ( not defined ${$dsl} ) { Marpa::R2::exception( qq{'$arg_name' name argument to Marpa::R2::Scanless::G->new() is a ref to a an undef\n}, " It should be a ref to a string\n" ); } ## end if ( $ref_type ne 'SCALAR' ) } ## end if ( $method eq 'new' ) # A bit hack-ish, but some named args will be copies straight to a member of # the Scanless::G class, so this maps named args to the index of the array # that holds the members. state $copy_arg_to_index = { trace_file_handle => Marpa::R2::Internal::Scanless::G::TRACE_FILE_HANDLE, trace_terminals => Marpa::R2::Internal::Scanless::G::TRACE_TERMINALS }; ARG: for my $arg_name ( keys %flat_args ) { my $index = $copy_arg_to_index->{$arg_name}; next ARG if not defined $index; my $value = $flat_args{$arg_name}; $slg->[$index] = $value; } ## end ARG: for my $arg_name ( keys %flat_args ) # Trace file handle needs to be populated downwards if ( defined( my $trace_file_handle = $flat_args{trace_file_handle} ) ) { GRAMMAR: for my $naif_grammar ( $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR], @{ $slg->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS] } ) { next GRAMMAR if not defined $naif_grammar; $naif_grammar->set( { trace_file_handle => $trace_file_handle } ); } ## end GRAMMAR: for my $naif_grammar ( $slg->[...]) } ## end if ( defined( my $trace_file_handle = $flat_args{...})) if ( $method eq 'new' ) { # Prune flat args of all those named args which are NOT to be copied # into the NAIF recce args for my $arg_name ( keys %flat_args ) { delete $flat_args{$arg_name} if not $copy_to_g1_args->{$arg_name}; } # trace file handle must always be defined $slg->[Marpa::R2::Internal::Scanless::G::TRACE_FILE_HANDLE] //= \*STDERR; return ($dsl, \%flat_args); } ## end if ( $method eq 'new' ) return; } ## end sub Marpa::R2::Internal::Scanless::G::set sub Marpa::R2::Internal::Scanless::G::hash_to_runtime { my ( $slg, $hashed_source, $g1_args ) = @_; my $trace_terminals = $slg->[Marpa::R2::Internal::Scanless::G::TRACE_TERMINALS] // 0; # Pre-lexer G1 processing my $start_lhs = $hashed_source->{'start_lhs'} // $hashed_source->{'first_lhs'}; Marpa::R2::exception('No rules in SLIF grammar') if not defined $start_lhs; Marpa::R2::Internal::MetaAST::start_rule_create( $hashed_source, $start_lhs ); $slg->[Marpa::R2::Internal::Scanless::G::CACHE_RULEIDS_BY_LHS_NAME] = {}; $slg->[Marpa::R2::Internal::Scanless::G::DEFAULT_G1_START_ACTION] = $hashed_source->{'default_g1_start_action'}; my $trace_fh = $slg->[Marpa::R2::Internal::Scanless::G::TRACE_FILE_HANDLE] = $g1_args->{trace_file_handle} // \*STDERR; my $if_inaccessible_default = $hashed_source->{defaults}->{if_inaccessible} // 'warn'; # Prepare the arguments for the G1 grammar $g1_args->{rules} = $hashed_source->{rules}->{G1}; $g1_args->{symbols} = $hashed_source->{symbols}->{G1}; state $g1_target_symbol = '[:start]'; $g1_args->{start} = $g1_target_symbol; $g1_args->{'_internal_'} = { 'if_inaccessible' => $if_inaccessible_default }; my $thick_g1_grammar = Marpa::R2::Grammar->new($g1_args); my $g1_tracer = $thick_g1_grammar->tracer(); my $g1_thin = $g1_tracer->grammar(); my $symbol_ids_by_event_name_and_type = {}; $slg->[Marpa::R2::Internal::Scanless::G::SYMBOL_IDS_BY_EVENT_NAME_AND_TYPE] = $symbol_ids_by_event_name_and_type; my $completion_events_by_name = $hashed_source->{completion_events}; my $completion_events_by_id = $slg->[Marpa::R2::Internal::Scanless::G::COMPLETION_EVENT_BY_ID] = []; for my $symbol_name ( keys %{$completion_events_by_name} ) { my $event_name = $completion_events_by_name->{$symbol_name}; my $symbol_id = $g1_tracer->symbol_by_name($symbol_name); if ( not defined $symbol_id ) { Marpa::R2::exception( "Completion event defined for non-existent symbol: $symbol_name\n" ); } # Must be done before precomputation $g1_thin->symbol_is_completion_event_set( $symbol_id, 1 ); $slg->[Marpa::R2::Internal::Scanless::G::COMPLETION_EVENT_BY_ID] ->[$symbol_id] = $completion_events_by_name->{$symbol_name}; push @{ $symbol_ids_by_event_name_and_type->{$event_name}->{completion} }, $symbol_id; } ## end for my $symbol_name ( keys %{$completion_events_by_name...}) my $nulled_events_by_name = $hashed_source->{nulled_events}; my $nulled_events_by_id = $slg->[Marpa::R2::Internal::Scanless::G::NULLED_EVENT_BY_ID] = []; for my $symbol_name ( keys %{$nulled_events_by_name} ) { my $event_name = $nulled_events_by_name->{$symbol_name}; my $symbol_id = $g1_tracer->symbol_by_name($symbol_name); if ( not defined $symbol_id ) { Marpa::R2::exception( "nulled event defined for non-existent symbol: $symbol_name\n" ); } # Must be done before precomputation $g1_thin->symbol_is_nulled_event_set( $symbol_id, 1 ); $slg->[Marpa::R2::Internal::Scanless::G::NULLED_EVENT_BY_ID] ->[$symbol_id] = $nulled_events_by_name->{$symbol_name}; push @{ $symbol_ids_by_event_name_and_type->{$event_name}->{nulled} }, $symbol_id; } ## end for my $symbol_name ( keys %{$nulled_events_by_name} ) my $prediction_events_by_name = $hashed_source->{prediction_events}; my $prediction_events_by_id = $slg->[Marpa::R2::Internal::Scanless::G::PREDICTION_EVENT_BY_ID] = []; for my $symbol_name ( keys %{$prediction_events_by_name} ) { my $event_name = $prediction_events_by_name->{$symbol_name}; my $symbol_id = $g1_tracer->symbol_by_name($symbol_name); if ( not defined $symbol_id ) { Marpa::R2::exception( "prediction event defined for non-existent symbol: $symbol_name\n" ); } # Must be done before precomputation $g1_thin->symbol_is_prediction_event_set( $symbol_id, 1 ); $slg->[Marpa::R2::Internal::Scanless::G::PREDICTION_EVENT_BY_ID] ->[$symbol_id] = $prediction_events_by_name->{$symbol_name}; push @{ $symbol_ids_by_event_name_and_type->{$event_name}->{prediction} }, $symbol_id; } ## end for my $symbol_name ( keys %{$prediction_events_by_name...}) my $lexeme_events_by_id = $slg->[Marpa::R2::Internal::Scanless::G::LEXEME_EVENT_BY_ID] = []; if (defined( my $precompute_error = Marpa::R2::Internal::Grammar::slif_precompute( $thick_g1_grammar) ) ) { if ( $precompute_error == $Marpa::R2::Error::UNPRODUCTIVE_START ) { # Maybe someday improve this by finding the start rule and showing # its RHS -- for now it is clear enough Marpa::R2::exception(qq{Unproductive start symbol}); } ## end if ( $precompute_error == ...) Marpa::R2::exception( 'Internal errror: unnkown precompute error code ', $precompute_error ); } ## end if ( defined( my $precompute_error = ...)) # Current lexeme data is spread out in many places. # Change so that it all resides in this hash, indexed by # name my %lexeme_data = (); # Find out the list of lexemes according to G1 # g1_lexeme[] is defined for G1 lexemes -- set to 0 # g1_lexeme is incremented for each lexer which uses it SYMBOL: for my $symbol_id ( 0 .. $g1_thin->highest_symbol_id() ) { # Not a lexeme, according to G1 next SYMBOL if not $g1_thin->symbol_is_terminal($symbol_id); my $symbol_name = $g1_tracer->symbol_name($symbol_id); $lexeme_data{$symbol_name}{'G1'}{'id'} = $symbol_id; } ## end SYMBOL: for my $symbol_id ( 0 .. $g1_thin->highest_symbol_id(...)) # A first phase of applying defaults my $lexeme_declarations = $hashed_source->{lexeme_declarations}; my $lexeme_default_adverbs = $hashed_source->{lexeme_default_adverbs}; my $latm_default_value = $lexeme_default_adverbs->{latm} // 0; # Determine "latm" status LEXEME: for my $lexeme_name ( keys %lexeme_data ) { my $declarations = $lexeme_declarations->{$lexeme_name}; my $latm_value = $declarations->{latm} // $latm_default_value; $lexeme_data{$lexeme_name}{latm} = $latm_value; } # Lexers my %grammars = (); $grammars{$_} = 1 for keys %{ $hashed_source->{rules} }; my @lexer_names = grep { ( substr $_, 0, 1 ) eq 'L' } keys %grammars; my %lexer_id_by_name = (); my %thick_grammar_by_lexer_name = (); my %lexer_and_rule_to_g1_lexeme = (); my %character_class_table_by_lexer_name = (); state $lex_start_symbol_name = '[:start_lex]'; state $discard_symbol_name = '[:discard]'; # Need to clean up determination of lexeme status my $lexer_symbols = $hashed_source->{symbols}->{'L'}; for my $lexer_name (@lexer_names) { my $lexer_rules = $hashed_source->{rules}->{$lexer_name}; Marpa::R2::exception("No rules for lexer $lexer_name") if not $lexer_rules; my %lex_lhs = (); my %lex_rhs = (); my %lex_separator = (); for my $lex_rule ( @{$lexer_rules} ) { $lex_lhs{ $lex_rule->{lhs} } = 1; $lex_rhs{$_} = 1 for @{ $lex_rule->{rhs} }; if ( defined( my $separator = $lex_rule->{separator} ) ) { $lex_separator{$separator} = 1; } } ## end for my $lex_rule ( @{$lexer_rules} ) my %this_lexer_symbols = (); SYMBOL: for my $symbol_name ( ( keys %lex_lhs ), ( keys %lex_rhs ), ( keys %lex_separator ) ) { my $symbol_data = $lexer_symbols->{$symbol_name}; $this_lexer_symbols{$symbol_name} = $symbol_data if defined $symbol_data; } my %is_lexeme_in_this_lexer = map { $_ => 1 } grep { not $lex_rhs{$_} and not $lex_separator{$_} } keys %lex_lhs; my @lex_lexeme_names = keys %is_lexeme_in_this_lexer; Marpa::R2::exception( "No lexemes in lexer: $lexer_name\n", " An SLIF grammar must have at least one lexeme\n" ) if not scalar @lex_lexeme_names; # Do I need this? my @unproductive = map {"<$_>"} grep { not $lex_lhs{$_} and not $_ =~ /\A \[\[ /xms } ( keys %lex_rhs, keys %lex_separator ); if (@unproductive) { Marpa::R2::exception( 'Unproductive lexical symbols: ', join q{ }, @unproductive ); } $this_lexer_symbols{$lex_start_symbol_name}->{display_form} = ':start_lex'; $this_lexer_symbols{$lex_start_symbol_name}->{description} = 'Internal L0 (lexical) start symbol'; push @{ $lexer_rules }, map { ; { description => "Internal lexical start rule for <$_>", lhs => $lex_start_symbol_name, rhs => [$_] } } sort keys %is_lexeme_in_this_lexer; # Prepare the arguments for the lex grammar my %lex_args = (); $lex_args{trace_file_handle} = $trace_fh; $lex_args{start} = $lex_start_symbol_name; $lex_args{'_internal_'} = { 'if_inaccessible' => $if_inaccessible_default }; $lex_args{rules} = $lexer_rules; $lex_args{symbols} = \%this_lexer_symbols; my $lex_grammar = Marpa::R2::Grammar->new( \%lex_args ); $thick_grammar_by_lexer_name{$lexer_name} = $lex_grammar; my $lex_tracer = $lex_grammar->tracer(); my $lex_thin = $lex_tracer->grammar(); my $lex_discard_symbol_id = $lex_tracer->symbol_by_name($discard_symbol_name) // -1; my @lex_lexeme_to_g1_symbol; $lex_lexeme_to_g1_symbol[$_] = -1 for 0 .. $g1_thin->highest_symbol_id(); LEXEME_NAME: for my $lexeme_name (@lex_lexeme_names) { next LEXEME_NAME if $lexeme_name eq $discard_symbol_name; next LEXEME_NAME if $lexeme_name eq $lex_start_symbol_name; my $this_lexeme_data = $lexeme_data{$lexeme_name}; my $g1_symbol_id = $this_lexeme_data->{'G1'}->{'id'}; if ( not defined $g1_symbol_id ) { Marpa::R2::exception( "A lexeme in lexer $lexer_name is not a lexeme in G1: $lexeme_name" ); } if ( not $g1_thin->symbol_is_accessible($g1_symbol_id) ) { my $message = "A lexeme in lexer $lexer_name is not accessible from the G1 start symbol: $lexeme_name"; say {$trace_fh} $message if $if_inaccessible_default eq 'warn'; Marpa::R2::exception($message) if $if_inaccessible_default eq 'fatal'; } my $lex_symbol_id = $lex_tracer->symbol_by_name($lexeme_name); $lexeme_data{$lexeme_name}{lexers}{$lexer_name}{'id'} = $lex_symbol_id; $lex_lexeme_to_g1_symbol[$lex_symbol_id] = $g1_symbol_id; } my @lex_rule_to_g1_lexeme; my $lex_start_symbol_id = $lex_tracer->symbol_by_name($lex_start_symbol_name); RULE_ID: for my $rule_id ( 0 .. $lex_thin->highest_rule_id() ) { my $lhs_id = $lex_thin->rule_lhs($rule_id); if ($lhs_id == $lex_discard_symbol_id) { $lex_rule_to_g1_lexeme[$rule_id] = -2; next RULE_ID; } if ($lhs_id != $lex_start_symbol_id) { $lex_rule_to_g1_lexeme[$rule_id] = -1; next RULE_ID; } my $lexer_lexeme_id = $lex_thin->rule_rhs($rule_id, 0); if ($lexer_lexeme_id == $lex_discard_symbol_id) { $lex_rule_to_g1_lexeme[$rule_id] = -1; next RULE_ID; } my $lexeme_id = $lex_lexeme_to_g1_symbol[$lexer_lexeme_id] // -1 ; $lex_rule_to_g1_lexeme[$rule_id] = $lexeme_id; next RULE_ID if $lexeme_id < 0; my $lexeme_name = $g1_tracer->symbol_name($lexeme_id); # If 1 is the default, we don't need an assertion next RULE_ID if not $lexeme_data{$lexeme_name}{latm}; my $assertion_id = $lexeme_data{$lexeme_name}{lexers}{$lexer_name}{'assertion'}; if ( not defined $assertion_id ) { $assertion_id = $lex_thin->zwa_new(0); if ( $trace_terminals >= 2 ) { say {$trace_fh} "Assertion $assertion_id defaults to 0"; } ## end if ( $trace_terminals >= 2 ) $lexeme_data{$lexeme_name}{lexers}{$lexer_name}{'assertion'} = $assertion_id; } ## end if ( not defined $assertion_id ) $lex_thin->zwa_place( $assertion_id, $rule_id, 0 ); if ( $trace_terminals >= 2 ) { say {$trace_fh} "Assertion $assertion_id applied to $lexer_name rule ", slg_rule_show( $slg, $rule_id, $lex_grammar ); } ## end if ( $trace_terminals >= 2 ) } ## end RULE_ID: for my $rule_id ( 0 .. $lex_thin->highest_rule_id() ) Marpa::R2::Internal::Grammar::slif_precompute($lex_grammar); my $character_class_hash = $hashed_source->{character_classes}; my @class_table = (); CLASS_SYMBOL: for my $class_symbol ( sort keys %{$character_class_hash} ) { my $symbol_id = $lex_tracer->symbol_by_name($class_symbol); next CLASS_SYMBOL if not defined $symbol_id; my $cc_components = $character_class_hash->{$class_symbol}; my ( $compiled_re, $error ) = Marpa::R2::Internal::MetaAST::char_class_to_re( $cc_components); if ( not $compiled_re ) { $error =~ s/^/ /gxms; #indent all lines Marpa::R2::exception( "Failed belatedly to evaluate character class\n", $error ); } ## end if ( not $compiled_re ) push @class_table, [ $symbol_id, $compiled_re ]; } ## end for my $class_symbol ( sort keys %{$character_class_hash...}) $character_class_table_by_lexer_name{$lexer_name} = \@class_table; $lexer_and_rule_to_g1_lexeme{$lexer_name} = \@lex_rule_to_g1_lexeme; } ## end for my $lexer_name (@lexer_names) # Post-lexer G1 processing my $thick_L0 = $thick_grammar_by_lexer_name{'L0'}; my $thin_L0 = $thick_L0->[Marpa::R2::Internal::Grammar::C]; my $thin_slg = $slg->[Marpa::R2::Internal::Scanless::G::C] = Marpa::R2::Thin::SLG->new( $thin_L0, $g1_tracer->grammar() ); # Relies on default lexer being given number zero $lexer_id_by_name{'L0'} = 0; LEXER: for my $lexer_name (@lexer_names) { next LEXER if $lexer_name eq 'L0'; my $thick_g = $thick_grammar_by_lexer_name{$lexer_name}; my $thin_g = $thick_g->[Marpa::R2::Internal::Grammar::C]; $lexer_id_by_name{$lexer_name} = $thin_slg->lexer_add($thin_g); } LEXEME: for my $lexeme_name ( keys %lexeme_data ) { Marpa::R2::exception( "A lexeme in G1 is not a lexeme in any of the lexers: $lexeme_name" ) if not defined $lexeme_data{$lexeme_name}{'lexers'}; } # At this point we know which symbols are lexemes. # More processing of G1 lexemes for my $lexeme_name ( keys %{$lexeme_declarations} ) { my $declarations = $lexeme_declarations->{$lexeme_name}; my $g1_lexeme_id = $g1_tracer->symbol_by_name($lexeme_name); Marpa::R2::exception( "Symbol <$lexeme_name> is declared as a lexeme, but it is not used as one.\n" ) if not defined $lexeme_data{$lexeme_name}{'G1'}; if ( defined( my $value = $declarations->{priority} ) ) { $thin_slg->g1_lexeme_priority_set( $g1_lexeme_id, $value ); } my $pause_value = $declarations->{pause}; if ( defined $pause_value ) { $thin_slg->g1_lexeme_pause_set( $g1_lexeme_id, $pause_value ); if ( defined( my $event_name = $declarations->{'event'} ) ) { $lexeme_events_by_id->[$g1_lexeme_id] = $event_name; push @{ $symbol_ids_by_event_name_and_type->{$event_name} ->{lexeme} }, $g1_lexeme_id; } } ## end if ( defined $pause_value ) } ## end for my $lexeme_name ( keys %{$lexeme_declarations} ) # Now that we know the lexemes, check attempts to defined a # completion or a nulled event for one for my $symbol_name ( keys %{$completion_events_by_name} ) { Marpa::R2::exception( "A completion event is declared for <$symbol_name>, but it is a lexeme.\n", " Completion events are only valid for symbols on the LHS of G1 rules.\n" ) if defined $lexeme_data{$symbol_name}{'G1'} } ## end for my $symbol_name ( keys %{$completion_events_by_name...}) for my $symbol_name ( keys %{$nulled_events_by_name} ) { Marpa::R2::exception( "A nulled event is declared for <$symbol_name>, but it is a G1 lexeme.\n", " nulled events are only valid for symbols on the LHS of G1 rules.\n" ) if defined $lexeme_data{$symbol_name}{'G1'} } ## end for my $symbol_name ( keys %{$nulled_events_by_name} ) # Now that we have created the SLG, we can set the latm value, # already determined above. LEXEME: for my $lexeme_name (keys %lexeme_data) { my $g1_lexeme_id = $lexeme_data{$lexeme_name}{'G1'}{'id'}; next LEXEME if not defined $g1_lexeme_id; my $latm_value = $lexeme_data{$lexeme_name}{latm} // 0; $thin_slg->g1_lexeme_latm_set( $g1_lexeme_id, $latm_value ); } # Second phase of lexer processing for my $lexer_name (@lexer_names) { my $lexer_rule_to_g1_lexeme = $lexer_and_rule_to_g1_lexeme{$lexer_name}; my $lexer_id = $lexer_id_by_name{$lexer_name}; RULE_ID: for my $lexer_rule_id ( 0 .. $#{$lexer_rule_to_g1_lexeme} ) { my $g1_lexeme_id = $lexer_rule_to_g1_lexeme->[$lexer_rule_id]; my $lexeme_name = $g1_tracer->symbol_name($g1_lexeme_id); my $assertion_id = $lexeme_data{$lexeme_name}{lexers}{$lexer_name}{'assertion'} // -1; $thin_slg->lexer_rule_to_g1_lexeme_set( $lexer_id, $lexer_rule_id, $g1_lexeme_id, $assertion_id ); } } ## end for my $lexer_name (@lexer_names) # Second phase of G1 processing $thin_slg->precompute(); $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR] = $thick_g1_grammar; for my $lexer_name (@lexer_names) { my $lexer_id = $lexer_id_by_name{$lexer_name}; my $external_lexer_name = ( substr $lexer_name, 0, 2 ) eq 'L-' ? substr $lexer_name, 2 : $lexer_name; my $character_class_table = $character_class_table_by_lexer_name{$lexer_name}; $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID]->[$lexer_id] = $external_lexer_name; $slg->[Marpa::R2::Internal::Scanless::G::LEXER_BY_NAME] ->{$external_lexer_name} = $lexer_id; $slg->[Marpa::R2::Internal::Scanless::G::CHARACTER_CLASS_TABLES] ->[$lexer_id] = $character_class_table; $slg->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS]->[$lexer_id] = $thick_grammar_by_lexer_name{$lexer_name}; } ## end for my $lexer_name (@lexer_names) # This section violates the NAIF interface, directly changing some # of its internal structures. # # Some lexeme default adverbs are applied in earlier phases. # APPLY_DEFAULT_LEXEME_ADVERBS: { last APPLY_DEFAULT_LEXEME_ADVERBS if not $lexeme_default_adverbs; my $action = $lexeme_default_adverbs->{action}; my $g1_symbols = $thick_g1_grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; LEXEME: for my $lexeme_name ( keys %lexeme_data ) { my $g1_lexeme_id = $lexeme_data{$lexeme_name}{'G1'}{'id'}; next LEXEME if not defined $g1_lexeme_id; my $g1_symbol = $g1_symbols->[$g1_lexeme_id]; next LEXEME if $lexeme_name =~ m/ \] \z/xms; $g1_symbol->[Marpa::R2::Internal::Symbol::LEXEME_SEMANTICS] //= $action; } my $blessing = $lexeme_default_adverbs->{bless}; last APPLY_DEFAULT_LEXEME_ADVERBS if not $blessing; last APPLY_DEFAULT_LEXEME_ADVERBS if $blessing eq '::undef'; LEXEME: for my $lexeme_name ( keys %lexeme_data ) { my $g1_lexeme_id = $lexeme_data{$lexeme_name}{'G1'}{'id'}; next LEXEME if not defined $g1_lexeme_id; my $g1_symbol = $g1_symbols->[$g1_lexeme_id]; next LEXEME if $lexeme_name =~ m/ \] \z/xms; if ( $blessing eq '::name' ) { if ( $lexeme_name =~ / [^ [:alnum:]] /xms ) { Marpa::R2::exception( qq{Lexeme blessing by '::name' only allowed if lexeme name is whitespace and alphanumerics\n}, qq{ Problematic lexeme was <$lexeme_name>\n} ); } ## end if ( $lexeme_name =~ / [^ [:alnum:]] /xms ) my $blessing_by_name = $lexeme_name; $blessing_by_name =~ s/[ ]/_/gxms; $g1_symbol->[Marpa::R2::Internal::Symbol::BLESSING] //= $blessing_by_name; next LEXEME; } ## end if ( $blessing eq '::name' ) if ( $blessing =~ / [\W] /xms ) { Marpa::R2::exception( qq{Blessing lexeme as '$blessing' is not allowed\n}, qq{ Problematic lexeme was <$lexeme_name>\n} ); } ## end if ( $blessing =~ / [\W] /xms ) $g1_symbol->[Marpa::R2::Internal::Symbol::BLESSING] //= $blessing; } } ## end APPLY_DEFAULT_LEXEME_ADVERBS: return $slg; } sub thick_subgrammar_by_name { my ( $slg, $subgrammar ) = @_; $subgrammar //= 'G1'; return $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR] if $subgrammar eq 'G1'; # Allow G0 as legacy synonym for L0 $subgrammar = 'L0' if $subgrammar eq 'G0'; my $lexer_id = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_BY_NAME]->{$subgrammar}; Marpa::R2::exception(qq{No lexer named "$subgrammar"}) if not defined $lexer_id; return $slg->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS] ->[$lexer_id]; } ## end sub thick_subgrammar_by_name sub Marpa::R2::Scanless::G::start_symbol_id { my ( $slg, $rule_id, $subgrammar ) = @_; return thick_subgrammar_by_name( $slg, $subgrammar )->start_symbol(); } sub Marpa::R2::Scanless::G::rule_name { my ( $slg, $rule_id, $subgrammar ) = @_; return thick_subgrammar_by_name( $slg, $subgrammar )->rule_name($rule_id); } sub Marpa::R2::Scanless::G::rule_expand { my ( $slg, $rule_id, $subgrammar ) = @_; return thick_subgrammar_by_name( $slg, $subgrammar )->tracer() ->rule_expand($rule_id); } sub Marpa::R2::Scanless::G::symbol_name { my ( $slg, $symbol_id, $subgrammar ) = @_; return thick_subgrammar_by_name($slg, $subgrammar)->tracer() ->symbol_name($symbol_id); } sub Marpa::R2::Scanless::G::symbol_display_form { my ( $slg, $symbol_id, $subgrammar ) = @_; return thick_subgrammar_by_name( $slg, $subgrammar ) ->symbol_in_display_form($symbol_id); } sub Marpa::R2::Scanless::G::symbol_dsl_form { my ( $slg, $symbol_id, $subgrammar ) = @_; return thick_subgrammar_by_name( $slg, $subgrammar ) ->symbol_dsl_form($symbol_id); } sub Marpa::R2::Scanless::G::symbol_description { my ( $slg, $symbol_id, $subgrammar ) = @_; return thick_subgrammar_by_name($slg, $subgrammar) ->symbol_description($symbol_id); } sub Marpa::R2::Scanless::G::rule_show { my ( $slg, $rule_id, $subgrammar) = @_; return slg_rule_show($slg, $rule_id, thick_subgrammar_by_name($slg, $subgrammar)); } sub slg_rule_show { my ( $slg, $rule_id, $subgrammar ) = @_; my $tracer = $subgrammar->tracer(); my $subgrammar_c = $subgrammar->[Marpa::R2::Internal::Grammar::C]; my @symbol_ids = $tracer->rule_expand($rule_id); return if not scalar @symbol_ids; my ( $lhs, @rhs ) = map { $subgrammar->symbol_in_display_form($_) } @symbol_ids; my $minimum = $subgrammar_c->sequence_min($rule_id); my @quantifier = (); if ( defined $minimum ) { @quantifier = ( $minimum <= 0 ? q{*} : q{+} ); } return join q{ }, $lhs, q{::=}, @rhs, @quantifier; } ## end sub slg_rule_show sub Marpa::R2::Scanless::G::show_rules { my ( $slg, $verbose, $subgrammar ) = @_; my $text = q{}; $verbose //= 0; $subgrammar //= 'G1'; my $thick_grammar = thick_subgrammar_by_name($slg, $subgrammar); my $rules = $thick_grammar->[Marpa::R2::Internal::Grammar::RULES]; my $grammar_c = $thick_grammar->[Marpa::R2::Internal::Grammar::C]; for my $rule ( @{$rules} ) { my $rule_id = $rule->[Marpa::R2::Internal::Rule::ID]; my $minimum = $grammar_c->sequence_min($rule_id); my @quantifier = defined $minimum ? $minimum <= 0 ? (q{*}) : (q{+}) : (); my $lhs_id = $grammar_c->rule_lhs($rule_id); my $rule_length = $grammar_c->rule_length($rule_id); my @rhs_ids = map { $grammar_c->rule_rhs( $rule_id, $_ ) } ( 0 .. $rule_length - 1 ); $text .= join q{ }, $subgrammar, "R$rule_id", $thick_grammar->symbol_in_display_form($lhs_id), '::=', ( map { $thick_grammar->symbol_in_display_form($_) } @rhs_ids ), @quantifier; $text .= "\n"; if ( $verbose >= 2 ) { my $description = $rule->[Marpa::R2::Internal::Rule::DESCRIPTION]; $text .= " $description\n" if $description; my @comment = (); $grammar_c->rule_length($rule_id) == 0 and push @comment, 'empty'; $thick_grammar->rule_is_used($rule_id) or push @comment, '!used'; $grammar_c->rule_is_productive($rule_id) or push @comment, 'unproductive'; $grammar_c->rule_is_accessible($rule_id) or push @comment, 'inaccessible'; $rule->[Marpa::R2::Internal::Rule::DISCARD_SEPARATION] and push @comment, 'discard_sep'; if (@comment) { $text .= q{ } . ( join q{ }, q{/*}, @comment, q{*/} ) . "\n"; } $text .= " Symbol IDs: <$lhs_id> ::= " . ( join q{ }, map {"<$_>"} @rhs_ids ) . "\n"; } ## end if ( $verbose >= 2 ) if ( $verbose >= 3 ) { my $tracer = $thick_grammar->tracer(); $text .= " Internal symbols: <" . $tracer->symbol_name($lhs_id) . q{> ::= } . ( join q{ }, map { '<' . $tracer->symbol_name($_) . '>' } @rhs_ids ) . "\n"; } ## end if ( $verbose >= 3 ) } ## end for my $rule ( @{$rules} ) return $text; } ## end sub Marpa::R2::Scanless::G::show_rules sub Marpa::R2::Scanless::G::show_symbols { my ( $slg, $verbose, $subgrammar ) = @_; my $text = q{}; $verbose //= 0; $subgrammar //= 'G1'; my $thick_grammar = thick_subgrammar_by_name($slg, $subgrammar); my $symbols = $thick_grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $grammar_c = $thick_grammar->[Marpa::R2::Internal::Grammar::C]; for my $symbol ( @{$symbols} ) { my $symbol_id = $symbol->[Marpa::R2::Internal::Symbol::ID]; $text .= join q{ }, $subgrammar, "S$symbol_id", $thick_grammar->symbol_in_display_form($symbol_id); my $description = $symbol->[Marpa::R2::Internal::Symbol::DESCRIPTION]; if ($description) { $text .= " -- $description"; } $text .= "\n"; if ( $verbose >= 2 ) { my @tag_list = (); $grammar_c->symbol_is_productive($symbol_id) or push @tag_list, 'unproductive'; $grammar_c->symbol_is_accessible($symbol_id) or push @tag_list, 'inaccessible'; $grammar_c->symbol_is_nulling($symbol_id) and push @tag_list, 'nulling'; $grammar_c->symbol_is_terminal($symbol_id) and push @tag_list, 'terminal'; if (@tag_list) { $text .= q{ } . ( join q{ }, q{/*}, @tag_list, q{*/} ) . "\n"; } my $tracer = $thick_grammar->tracer(); $text .= " Internal name: <" . $tracer->symbol_name($symbol_id) . qq{>\n}; } ## end if ( $verbose >= 2 ) if ( $verbose >= 3 ) { my $dsl_form = $symbol->[Marpa::R2::Internal::Symbol::DSL_FORM]; if ($dsl_form) { $text .= qq{ SLIF name: $dsl_form\n}; } } ## end if ( $verbose >= 3 ) } ## end for my $symbol ( @{$symbols} ) return $text; } ## end sub Marpa::R2::Scanless::G::show_symbols sub Marpa::R2::Scanless::G::show_dotted_rule { my ( $slg, $rule_id, $dot_position ) = @_; my $grammar = $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR]; my $tracer = $grammar->tracer(); my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my ( $lhs, @rhs ) = map { $grammar->symbol_in_display_form($_) } $tracer->rule_expand($rule_id); my $rhs_length = scalar @rhs; my $minimum = $grammar_c->sequence_min($rule_id); my @quantifier = (); if (defined $minimum) { @quantifier = ($minimum <= 0 ? q{*} : q{+} ); } $dot_position = 0 if $dot_position < 0; if ($dot_position < $rhs_length) { splice @rhs, $dot_position, 0, q{.}; return join q{ }, $lhs, q{->}, @rhs, @quantifier; } else { return join q{ }, $lhs, q{->}, @rhs, @quantifier, q{.}; } } ## end sub Marpa::R2::Grammar::show_dotted_rule sub Marpa::R2::Scanless::G::rule { my ( $slg, @args ) = @_; return $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR] ->rule(@args); } sub Marpa::R2::Scanless::G::rule_ids { my ($slg, $subgrammar) = @_; return thick_subgrammar_by_name($slg, $subgrammar)->rule_ids(); } sub Marpa::R2::Scanless::G::symbol_ids { my ($slg, $subgrammar) = @_; return thick_subgrammar_by_name($slg, $subgrammar)->symbol_ids(); } sub Marpa::R2::Scanless::G::g1_rule_ids { my ($slg) = @_; return $slg->rule_ids(); } sub Marpa::R2::Scanless::G::g0_rule_ids { my ($slg) = @_; return $slg->rule_ids('L0'); } sub Marpa::R2::Scanless::G::g0_rule { my ( $slg, @args ) = @_; return $slg->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS]->[0] ->rule(@args); } # Internal methods, not to be documented sub Marpa::R2::Scanless::G::thick_g1_grammar { my ($slg) = @_; return $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR]; } sub Marpa::R2::Scanless::G::show_irls { my ($slg, $subgrammar) = @_; return thick_subgrammar_by_name($slg, $subgrammar)->show_irls(); } 1; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/Grammar.pm0000444000000000000000000017601212342464706017064 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::Grammar; use 5.010; use warnings; # There's a problem with this perlcritic check # as of 9 Aug 2010 no warnings qw(recursion qw); use strict; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic(BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic package Marpa::R2::Internal::Grammar; use English qw( -no_match_vars ); use Marpa::R2::Thin::Trace; our %DEFAULT_SYMBOLS_RESERVED; %DEFAULT_SYMBOLS_RESERVED = map { ($_, 1) } split //xms, '}]>)'; sub Marpa::R2::uncaught_error { my ($error) = @_; # This would be Carp::confess, but in the testing # the stack trace includes the hoped for error # message, which causes spurious success reports. Carp::croak( "libmarpa reported an error which Marpa::R2 did not catch\n", $error ); } ## end sub Marpa::R2::uncaught_error package Marpa::R2::Internal::Grammar; sub Marpa::R2::Grammar::new { my ( $class, @arg_hashes ) = @_; my $grammar = []; bless $grammar, $class; # set the defaults and the default defaults $grammar->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE] = *STDERR; $grammar->[Marpa::R2::Internal::Grammar::TRACE_RULES] = 0; $grammar->[Marpa::R2::Internal::Grammar::WARNINGS] = 1; $grammar->[Marpa::R2::Internal::Grammar::INACCESSIBLE_OK] = {}; $grammar->[Marpa::R2::Internal::Grammar::UNPRODUCTIVE_OK] = {}; $grammar->[Marpa::R2::Internal::Grammar::INFINITE_ACTION] = 'fatal'; $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS] = []; $grammar->[Marpa::R2::Internal::Grammar::RULES] = []; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C] = Marpa::R2::Thin::G->new( { if => 1 } ); $grammar->[Marpa::R2::Internal::Grammar::TRACER] = Marpa::R2::Thin::Trace->new($grammar_c); $grammar->set(@arg_hashes); return $grammar; } ## end sub Marpa::R2::Grammar::new sub Marpa::R2::Grammar::tracer { return $_[0]->[Marpa::R2::Internal::Grammar::TRACER]; } sub Marpa::R2::Grammar::thin { return $_[0]->[Marpa::R2::Internal::Grammar::C]; } sub Marpa::R2::Grammar::thin_symbol { my ( $grammar, $symbol_name ) = @_; return $grammar->[Marpa::R2::Internal::Grammar::TRACER] ->symbol_by_name($symbol_name); } sub Marpa::R2::Grammar::set { my ( $grammar, @arg_hashes ) = @_; # set trace_fh even if no tracing, because we may turn it on in this method my $trace_fh = $grammar->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; for my $args (@arg_hashes) { my $ref_type = ref $args; if ( not $ref_type ) { Carp::croak( 'Marpa::R2::Grammar expects args as ref to HASH; arg was non-reference' ); } if ( $ref_type ne 'HASH' ) { Carp::croak( "Marpa::R2::Grammar expects args as ref to HASH, got ref to $ref_type instead" ); } state $grammar_options = { map { ( $_, 1 ) } qw{ _internal_ action_object actions bless_package infinite_action default_action default_empty_action default_rank inaccessible_ok rules source start symbols terminals trace_file_handle unproductive_ok warnings } }; if (my @bad_options = grep { not exists $grammar_options->{$_} } keys %{$args} ) { Carp::croak( 'Unknown option(s) for Marpa::R2::Grammar: ', join q{ }, @bad_options ); } ## end if ( my @bad_options = grep { not exists $grammar_options...}) # First pass options: These affect processing of other # options and are expected to take force for the other # options, even if specified afterwards if ( defined( my $value = $args->{'_internal_'} ) ) { $grammar->[Marpa::R2::Internal::Grammar::INTERNAL] = $value; } if ( defined( my $value = $args->{'trace_file_handle'} ) ) { $trace_fh = $grammar->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE] = $value; } if ( defined( my $value = $args->{'default_rank'} ) ) { Marpa::R2::exception( 'default_rank option not allowed after grammar is precomputed' ) if $grammar_c->is_precomputed(); $grammar_c->default_rank_set($value); } ## end if ( defined( my $value = $args->{'default_rank'} ) ) # Second pass options if ( defined( my $value = $args->{'symbols'} ) ) { Marpa::R2::exception( 'symbols option not allowed after grammar is precomputed') if $grammar_c->is_precomputed(); Marpa::R2::exception('symbols value must be REF to HASH') if ref $value ne 'HASH'; for my $symbol ( sort keys %{$value} ) { my $properties = $value->{$symbol}; assign_user_symbol( $grammar, $symbol, $properties ); } } ## end if ( defined( my $value = $args->{'symbols'} ) ) if ( defined( my $value = $args->{'terminals'} ) ) { Marpa::R2::exception( 'terminals option not allowed after grammar is precomputed') if $grammar_c->is_precomputed(); Marpa::R2::exception('terminals value must be REF to ARRAY') if ref $value ne 'ARRAY'; for my $symbol ( @{$value} ) { assign_user_symbol( $grammar, $symbol, { terminal => 1 } ); } } ## end if ( defined( my $value = $args->{'terminals'} ) ) if ( defined( my $value = $args->{'start'} ) ) { Marpa::R2::exception( 'start option not allowed after grammar is precomputed') if $grammar_c->is_precomputed(); $grammar->[Marpa::R2::Internal::Grammar::START_NAME] = $value; } ## end if ( defined( my $value = $args->{'start'} ) ) my $stuifzand_source; my $deprecated_source; if ( defined( my $value = $args->{'source'} ) ) { Marpa::R2::exception( 'source option not allowed after grammar is precomputed') if $grammar_c->is_precomputed(); Marpa::R2::exception( q{"source" named argument must be string or ref to SCALAR} ) if ref $value ne 'SCALAR'; $stuifzand_source = $value; } if ( defined( my $value = $args->{'rules'} ) ) { Marpa::R2::exception( 'rules option not allowed after grammar is precomputed') if $grammar_c->is_precomputed(); DO_RULES: { ## These hacks are for previous method of specifying Stuifzand ## grammars. They are now deprecated and undocumented. ## Eventually they may be eliminated. if ( ref $value eq 'ARRAY' and scalar @{$value} == 1 and not ref $value->[0] ) { $value = $value->[0]; } ## end if ( ref $value eq 'ARRAY' and scalar @{$value} == 1...) if ( not ref $value ) { $deprecated_source = \$value; } if (defined $deprecated_source and defined $stuifzand_source) { Marpa::R2::exception( qq{Attempt to specify BNF via both 'rules' and 'source' named arguments\n}, q{ You must use one or the other}, ) } if (defined $deprecated_source) { $stuifzand_source = $deprecated_source; last DO_RULES; } Marpa::R2::exception( q{"rules" named argument must be string or ref to ARRAY} ) if ref $value ne 'ARRAY'; $grammar->[Marpa::R2::Internal::Grammar::INTERFACE] //= 'standard'; Marpa::R2::exception( qq{Attempt to use the standard interface with a grammar that is already using the BNF interface\n}, q{ Mixing the BNF and standard interface is not allowed} ) if $grammar->[Marpa::R2::Internal::Grammar::INTERFACE] ne 'standard'; add_user_rules( $grammar, $value ); } ## end DO_RULES: } ## end if ( defined( my $value = $args->{'rules'} ) ) if ( defined $stuifzand_source ) { $grammar->[Marpa::R2::Internal::Grammar::INTERFACE] //= 'stuifzand'; Marpa::R2::exception( qq{Attempt to use the standard interface with a grammar that is already using the BNF interface\n}, q{ Mixing the BNF and standard interface is not allowed} ) if $grammar->[Marpa::R2::Internal::Grammar::INTERFACE] ne 'stuifzand'; my $parse_result = Marpa::R2::Internal::Stuifzand::parse_rules( $stuifzand_source ); for my $rule ( @{ $parse_result->{rules} } ) { add_user_rule( $grammar, $rule ); } } ## end if ( defined $stuifzand_source ) if ( exists $args->{'default_empty_action'} ) { my $value = $args->{'default_empty_action'}; $grammar->[Marpa::R2::Internal::Grammar::DEFAULT_EMPTY_ACTION] = $value; } if ( defined( my $value = $args->{'actions'} ) ) { $grammar->[Marpa::R2::Internal::Grammar::ACTIONS] = $value; } if ( defined( my $value = $args->{'bless_package'} ) ) { $grammar->[Marpa::R2::Internal::Grammar::BLESS_PACKAGE] = $value; } if ( defined( my $value = $args->{'action_object'} ) ) { $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT] = $value; } if ( defined( my $value = $args->{'default_action'} ) ) { $grammar->[Marpa::R2::Internal::Grammar::DEFAULT_ACTION] = $value; } if ( defined( my $value = $args->{'infinite_action'} ) ) { if ( $value && $grammar_c->is_precomputed() ) { say {$trace_fh} '"infinite_action" option is useless after grammar is precomputed' or Marpa::R2::exception("Could not print: $ERRNO"); } state $allowed_values = { map { ( $_, 1 ) } qw(warn quiet fatal) }; Marpa::R2::exception( q{infinite_action must be 'warn', 'quiet' or 'fatal'}) if not exists $allowed_values->{$value}; $grammar->[Marpa::R2::Internal::Grammar::INFINITE_ACTION] = $value; } ## end if ( defined( my $value = $args->{'infinite_action'}...)) if ( defined( my $value = $args->{'warnings'} ) ) { if ( $value && $grammar_c->is_precomputed() ) { say {$trace_fh} q{"warnings" option is useless after grammar is precomputed} or Marpa::R2::exception("Could not print: $ERRNO"); } $grammar->[Marpa::R2::Internal::Grammar::WARNINGS] = $value; } ## end if ( defined( my $value = $args->{'warnings'} ) ) if ( defined( my $value = $args->{'inaccessible_ok'} ) ) { if ( $value && $grammar_c->is_precomputed() ) { say {$trace_fh} q{"inaccessible_ok" option is useless after grammar is precomputed} or Marpa::R2::exception("Could not print: $ERRNO"); } ## end if ( $value && $grammar_c->is_precomputed() ) GIVEN_REF_VALUE: { my $ref_value = ref $value; if ( $ref_value eq q{} ) { $value //= {}; last GIVEN_REF_VALUE; } if ( $ref_value eq 'ARRAY' ) { $value = { map { ( $_, 1 ) } @{$value} }; last GIVEN_REF_VALUE; } Marpa::R2::exception( 'value of inaccessible_ok option must be boolean or an array ref' ); } ## end GIVEN_REF_VALUE: $grammar->[Marpa::R2::Internal::Grammar::INACCESSIBLE_OK] = $value; } ## end if ( defined( my $value = $args->{'inaccessible_ok'}...)) if ( defined( my $value = $args->{'unproductive_ok'} ) ) { if ( $value && $grammar_c->is_precomputed() ) { say {$trace_fh} q{"unproductive_ok" option is useless after grammar is precomputed} or Marpa::R2::exception("Could not print: $ERRNO"); } GIVEN_REF_VALUE: { my $ref_value = ref $value; if ( $ref_value eq q{} ) { $value //= {}; last GIVEN_REF_VALUE; } if ( $ref_value eq 'ARRAY' ) { $value = { map { ( $_, 1 ) } @{$value} }; last GIVEN_REF_VALUE; } Marpa::R2::exception( 'value of unproductive_ok option must be boolean or an array ref' ); } ## end GIVEN_REF_VALUE: $grammar->[Marpa::R2::Internal::Grammar::UNPRODUCTIVE_OK] = $value; } ## end if ( defined( my $value = $args->{'unproductive_ok'}...)) } ## end for my $args (@arg_hashes) return 1; } ## end sub Marpa::R2::Grammar::set sub Marpa::R2::Grammar::symbol_reserved_set { my ( $grammar, $final_character, $boolean ) = @_; if ( length $final_character != 1 ) { Marpa::R2::exception( 'symbol_reserved_set(): "', $final_character, '" is not a symbol' ); } if ( $final_character eq ']' ) { return if $boolean; Marpa::R2::exception( q{symbol_reserved_set(): Attempt to unreserve ']'; this is not allowed} ); } ## end if ( $final_character eq ']' ) ([) if ( not exists $DEFAULT_SYMBOLS_RESERVED{$final_character} ) { Marpa::R2::exception( qq{symbol_reserved_set(): "$final_character" is not a reservable symbol} ); } # Return a value to make perlcritic happy return $DEFAULT_SYMBOLS_RESERVED{$final_character} = $boolean ? 1 : 0; } ## end sub Marpa::R2::Grammar::symbol_reserved_set sub Marpa::R2::Grammar::precompute { my $grammar = shift; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $trace_fh = $grammar->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE]; my $problems = $grammar->[Marpa::R2::Internal::Grammar::PROBLEMS]; if ($problems) { Marpa::R2::exception( Marpa::R2::Grammar::show_problems($grammar), "Second attempt to precompute grammar with fatal problems\n", 'Marpa::R2 cannot proceed' ); } ## end if ($problems) return $grammar if $grammar_c->is_precomputed(); set_start_symbol($grammar); # Catch errors in precomputation my $precompute_error_code = $Marpa::R2::Error::NONE; $grammar_c->throw_set(0); my $precompute_result = $grammar_c->precompute(); $grammar_c->throw_set(1); if ( $precompute_result < 0 ) { ($precompute_error_code) = $grammar_c->error(); if ( not defined $precompute_error_code ) { Marpa::R2::exception( 'libmarpa error, but no error code returned'); } # If already precomputed, just return success return $grammar if $precompute_error_code == $Marpa::R2::Error::PRECOMPUTED; # Cycles are not necessarily errors, # and get special handling $precompute_error_code = $Marpa::R2::Error::NONE if $precompute_error_code == $Marpa::R2::Error::GRAMMAR_HAS_CYCLE; } ## end if ( $precompute_result < 0 ) if ( $precompute_error_code != $Marpa::R2::Error::NONE ) { # Report the errors, then return failure if ( $precompute_error_code == $Marpa::R2::Error::NO_RULES ) { Marpa::R2::exception( 'Attempted to precompute grammar with no rules'); } if ( $precompute_error_code == $Marpa::R2::Error::NULLING_TERMINAL ) { my @nulling_terminals = (); my $event_count = $grammar_c->event_count(); EVENT: for ( my $event_ix = 0; $event_ix < $event_count; $event_ix++ ) { my ( $event_type, $value ) = $grammar_c->event($event_ix); if ( $event_type eq 'MARPA_EVENT_NULLING_TERMINAL' ) { push @nulling_terminals, $grammar->symbol_name($value); } } ## end EVENT: for ( my $event_ix = 0; $event_ix < $event_count; ...) my @nulling_terminal_messages = map {qq{Nulling symbol "$_" is also a terminal\n}} @nulling_terminals; Marpa::R2::exception( @nulling_terminal_messages, 'A terminal symbol cannot also be a nulling symbol' ); } ## end if ( $precompute_error_code == ...) if ( $precompute_error_code == $Marpa::R2::Error::COUNTED_NULLABLE ) { my @counted_nullables = (); my $event_count = $grammar_c->event_count(); EVENT: for ( my $event_ix = 0; $event_ix < $event_count; $event_ix++ ) { my ( $event_type, $value ) = $grammar_c->event($event_ix); if ( $event_type eq 'MARPA_EVENT_COUNTED_NULLABLE' ) { push @counted_nullables, $grammar->symbol_name($value); } } ## end EVENT: for ( my $event_ix = 0; $event_ix < $event_count; ...) my @counted_nullable_messages = map { q{Nullable symbol "} . $_ . qq{" is on rhs of counted rule\n} } @counted_nullables; Marpa::R2::exception( @counted_nullable_messages, 'Counted nullables confuse Marpa -- please rewrite the grammar' ); } ## end if ( $precompute_error_code == ...) if ( $precompute_error_code == $Marpa::R2::Error::NO_START_SYMBOL ) { Marpa::R2::exception('No start symbol'); } if ( $precompute_error_code == $Marpa::R2::Error::START_NOT_LHS ) { my $name = $grammar->[Marpa::R2::Internal::Grammar::START_NAME]; Marpa::R2::exception( qq{Start symbol "$name" not on LHS of any rule}); } if ( $precompute_error_code == $Marpa::R2::Error::UNPRODUCTIVE_START ) { my $name = $grammar->[Marpa::R2::Internal::Grammar::START_NAME]; Marpa::R2::exception(qq{Unproductive start symbol: "$name"}); } Marpa::R2::uncaught_error( scalar $grammar_c->error() ); } ## end if ( $precompute_error_code != $Marpa::R2::Error::NONE) # Shadow all the new rules { my $highest_rule_id = $grammar_c->highest_rule_id(); RULE: for ( my $rule_id = 0; $rule_id <= $highest_rule_id; $rule_id++ ) { next RULE if defined $rules->[$rule_id]; # The Marpa::R2 logic assumes no "gaps" in the rule numbering, # which is currently the case for Libmarpa, # but not guaranteed. shadow_rule( $grammar, $rule_id ); } ## end RULE: for ( my $rule_id = 0; $rule_id <= $highest_rule_id; ...) } my $infinite_action = $grammar->[Marpa::R2::Internal::Grammar::INFINITE_ACTION]; # Above I went through the error events # Here I go through the events for situations where there was no # hard error returned from libmarpa my $loop_rule_count = 0; { my $event_count = $grammar_c->event_count(); EVENT: for ( my $event_ix = 0; $event_ix < $event_count; $event_ix++ ) { my ( $event_type, $value ) = $grammar_c->event($event_ix); if ( $event_type ne 'MARPA_EVENT_LOOP_RULES' ) { Marpa::R2::exception( qq{Unknown grammar precomputation event; type="$event_type"} ); } $loop_rule_count = $value; } ## end EVENT: for ( my $event_ix = 0; $event_ix < $event_count; ...) } if ( $loop_rule_count and $infinite_action ne 'quiet' ) { my @loop_rules = grep { $grammar_c->rule_is_loop($_) } ( 0 .. $#{$rules} ); for my $rule_id (@loop_rules) { print {$trace_fh} 'Cycle found involving rule: ', $grammar->brief_rule($rule_id), "\n" or Marpa::R2::exception("Could not print: $ERRNO"); } ## end for my $rule_id (@loop_rules) Marpa::R2::exception('Cycles in grammar, fatal error') if $infinite_action eq 'fatal'; } ## end if ( $loop_rule_count and $infinite_action ne 'quiet') # A bit hackish here: INACCESSIBLE_OK is not a HASH ref iff # it is a Boolean TRUE indicating that all inaccessibles are OK. # A Boolean FALSE will have been replaced with an empty hash. if ($grammar->[Marpa::R2::Internal::Grammar::WARNINGS] and ref( my $ok = $grammar->[Marpa::R2::Internal::Grammar::INACCESSIBLE_OK] ) eq 'HASH' ) { SYMBOL: for my $symbol ( @{ Marpa::R2::Grammar::inaccessible_symbols($grammar) } ) { # Inaccessible internal symbols may be created # from inaccessible use symbols -- ignore these. # This assumes that Marpa's logic # is correct and that # it is not creating inaccessible symbols from # accessible ones. next SYMBOL if $symbol =~ /\]/xms; next SYMBOL if $ok->{$symbol}; say {$trace_fh} "Inaccessible symbol: $symbol" or Marpa::R2::exception("Could not print: $ERRNO"); } ## end SYMBOL: for my $symbol ( @{ ...}) } ## end if ( $grammar->[Marpa::R2::Internal::Grammar::WARNINGS...]) # A bit hackish here: UNPRODUCTIVE_OK is not a HASH ref iff # it is a Boolean TRUE indicating that all inaccessibles are OK. # A Boolean FALSE will have been replaced with an empty hash. if ($grammar->[Marpa::R2::Internal::Grammar::WARNINGS] and ref( my $ok = $grammar->[Marpa::R2::Internal::Grammar::UNPRODUCTIVE_OK] ) eq 'HASH' ) { SYMBOL: for my $symbol ( @{ Marpa::R2::Grammar::unproductive_symbols($grammar) } ) { # Unproductive internal symbols may be created # from unproductive use symbols -- ignore these. # This assumes that Marpa's logic # is correct and that # it is not creating unproductive symbols from # productive ones. next SYMBOL if $symbol =~ /\]/xms; next SYMBOL if $ok->{$symbol}; say {$trace_fh} "Unproductive symbol: $symbol" or Marpa::R2::exception("Could not print: $ERRNO"); } ## end SYMBOL: for my $symbol ( @{ ...}) } ## end if ( $grammar->[Marpa::R2::Internal::Grammar::WARNINGS...]) # If we are using scannerless parsing, set that up Marpa::R2::exception("Internal error; precompute called for SLIF grammar") if $grammar->[Marpa::R2::Internal::Grammar::CHARACTER_CLASSES]; return $grammar; } ## end sub Marpa::R2::Grammar::precompute # A custom precompute for SLIF grammars sub Marpa::R2::Internal::Grammar::slif_precompute { my $grammar = shift; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $trace_fh = $grammar->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE]; my $problems = $grammar->[Marpa::R2::Internal::Grammar::PROBLEMS]; if ($problems) { Marpa::R2::exception( Marpa::R2::Grammar::show_problems($grammar), "Second attempt to precompute grammar with fatal problems\n", 'Marpa::R2 cannot proceed' ); } ## end if ($problems) return if $grammar_c->is_precomputed(); if ($grammar_c->force_valued() < 0) { Marpa::R2::uncaught_error( scalar $grammar_c->error() ); } set_start_symbol($grammar); # Catch errors in precomputation my $precompute_error_code = $Marpa::R2::Error::NONE; $grammar_c->throw_set(0); my $precompute_result = $grammar_c->precompute(); $grammar_c->throw_set(1); if ( $precompute_result < 0 ) { ($precompute_error_code) = $grammar_c->error(); if ( not defined $precompute_error_code ) { Marpa::R2::exception( 'libmarpa error, but no error code returned'); } # If already precomputed, let higher level know return $precompute_error_code if $precompute_error_code == $Marpa::R2::Error::PRECOMPUTED; # Cycles are not necessarily errors, # and get special handling $precompute_error_code = $Marpa::R2::Error::NONE if $precompute_error_code == $Marpa::R2::Error::GRAMMAR_HAS_CYCLE; } ## end if ( $precompute_result < 0 ) if ( $precompute_error_code != $Marpa::R2::Error::NONE ) { # Report the errors, then return failure if ( $precompute_error_code == $Marpa::R2::Error::NO_RULES ) { Marpa::R2::exception( 'Attempted to precompute grammar with no rules'); } if ( $precompute_error_code == $Marpa::R2::Error::NULLING_TERMINAL ) { my @nulling_terminals = (); my $event_count = $grammar_c->event_count(); EVENT: for ( my $event_ix = 0; $event_ix < $event_count; $event_ix++ ) { my ( $event_type, $value ) = $grammar_c->event($event_ix); if ( $event_type eq 'MARPA_EVENT_NULLING_TERMINAL' ) { push @nulling_terminals, $grammar->symbol_name($value); } } ## end EVENT: for ( my $event_ix = 0; $event_ix < $event_count; ...) my @nulling_terminal_messages = map {qq{Nulling symbol "$_" is also a terminal\n}} @nulling_terminals; Marpa::R2::exception( @nulling_terminal_messages, 'A terminal symbol cannot also be a nulling symbol' ); } ## end if ( $precompute_error_code == ...) if ( $precompute_error_code == $Marpa::R2::Error::COUNTED_NULLABLE ) { my @counted_nullables = (); my $event_count = $grammar_c->event_count(); EVENT: for ( my $event_ix = 0; $event_ix < $event_count; $event_ix++ ) { my ( $event_type, $value ) = $grammar_c->event($event_ix); if ( $event_type eq 'MARPA_EVENT_COUNTED_NULLABLE' ) { push @counted_nullables, $grammar->symbol_name($value); } } ## end EVENT: for ( my $event_ix = 0; $event_ix < $event_count; ...) my @counted_nullable_messages = map { q{Nullable symbol "} . $_ . qq{" is on rhs of counted rule\n} } @counted_nullables; Marpa::R2::exception( @counted_nullable_messages, 'Counted nullables confuse Marpa -- please rewrite the grammar' ); } ## end if ( $precompute_error_code == ...) if ( $precompute_error_code == $Marpa::R2::Error::NO_START_SYMBOL ) { Marpa::R2::exception('No start symbol'); } if ( $precompute_error_code == $Marpa::R2::Error::START_NOT_LHS ) { my $name = $grammar->[Marpa::R2::Internal::Grammar::START_NAME]; Marpa::R2::exception( qq{Start symbol "$name" not on LHS of any rule}); } return $precompute_error_code if $precompute_error_code == $Marpa::R2::Error::UNPRODUCTIVE_START; Marpa::R2::uncaught_error( scalar $grammar_c->error() ); } ## end if ( $precompute_error_code != $Marpa::R2::Error::NONE) # Shadow all the new rules { my $highest_rule_id = $grammar_c->highest_rule_id(); RULE: for ( my $rule_id = 0; $rule_id <= $highest_rule_id; $rule_id++ ) { next RULE if defined $rules->[$rule_id]; # The Marpa::R2 logic assumes no "gaps" in the rule numbering, # which is currently the case for Libmarpa, # but not guaranteed. shadow_rule( $grammar, $rule_id ); } ## end RULE: for ( my $rule_id = 0; $rule_id <= $highest_rule_id; ...) } my $infinite_action = $grammar->[Marpa::R2::Internal::Grammar::INFINITE_ACTION]; # Above I went through the error events # Here I go through the events for situations where there was no # hard error returned from libmarpa my $loop_rule_count = 0; { my $event_count = $grammar_c->event_count(); EVENT: for ( my $event_ix = 0; $event_ix < $event_count; $event_ix++ ) { my ( $event_type, $value ) = $grammar_c->event($event_ix); if ( $event_type ne 'MARPA_EVENT_LOOP_RULES' ) { Marpa::R2::exception( qq{Unknown grammar precomputation event; type="$event_type"} ); } $loop_rule_count = $value; } ## end EVENT: for ( my $event_ix = 0; $event_ix < $event_count; ...) } if ( $loop_rule_count and $infinite_action ne 'quiet' ) { my @loop_rules = grep { $grammar_c->rule_is_loop($_) } ( 0 .. $#{$rules} ); for my $rule_id (@loop_rules) { print {$trace_fh} 'Cycle found involving rule: ', $grammar->brief_rule($rule_id), "\n" or Marpa::R2::exception("Could not print: $ERRNO"); } ## end for my $rule_id (@loop_rules) Marpa::R2::exception('Cycles in grammar, fatal error') if $infinite_action eq 'fatal'; } ## end if ( $loop_rule_count and $infinite_action ne 'quiet') my $default_if_inaccessible = $grammar->[Marpa::R2::Internal::Grammar::INTERNAL]->{if_inaccessible} // 'warn'; SYMBOL: for my $symbol_id ( grep { !$grammar_c->symbol_is_accessible($_) } ( 0 .. $#{$symbols} ) ) { my $symbol = $symbols->[$symbol_id]; my $symbol_name = $grammar->symbol_name($symbol_id); # Inaccessible internal symbols may be created # from inaccessible use symbols -- ignore these. # This assumes that Marpa's logic # is correct and that # it is not creating inaccessible symbols from # accessible ones. next SYMBOL if $symbol_name =~ /\]/xms; my $treatment = $symbol->[Marpa::R2::Internal::Symbol::IF_INACCESSIBLE] // $default_if_inaccessible; next SYMBOL if $treatment eq 'ok'; my $message = "Inaccessible symbol: $symbol_name"; Marpa::R2::exception($message) if $treatment eq 'fatal'; say {$trace_fh} $message or Marpa::R2::exception("Could not print: $ERRNO"); } ## end for my $symbol_id ( grep { !$grammar_c->...}) # A bit hackish here: UNPRODUCTIVE_OK is not a HASH ref iff # it is a Boolean TRUE indicating that all inaccessibles are OK. # A Boolean FALSE will have been replaced with an empty hash. if ($grammar->[Marpa::R2::Internal::Grammar::WARNINGS] and ref( my $ok = $grammar->[Marpa::R2::Internal::Grammar::UNPRODUCTIVE_OK] ) eq 'HASH' ) { SYMBOL: for my $symbol ( @{ Marpa::R2::Grammar::unproductive_symbols($grammar) } ) { # Unproductive internal symbols may be created # from unproductive use symbols -- ignore these. # This assumes that Marpa's logic # is correct and that # it is not creating unproductive symbols from # productive ones. next SYMBOL if $symbol =~ /\]/xms; next SYMBOL if $ok->{$symbol}; say {$trace_fh} "Unproductive symbol: $symbol" or Marpa::R2::exception("Could not print: $ERRNO"); } ## end SYMBOL: for my $symbol ( @{ ...}) } ## end if ( $grammar->[Marpa::R2::Internal::Grammar::WARNINGS...]) my $cc_hash = $grammar->[Marpa::R2::Internal::Grammar::CHARACTER_CLASSES]; if ( defined $cc_hash ) { my $class_table = $grammar->[Marpa::R2::Internal::Grammar::CHARACTER_CLASS_TABLE] = []; for my $cc_symbol ( sort keys %{$cc_hash} ) { my $cc_components = $cc_hash->{$cc_symbol}; push @{$class_table}, [ $grammar->thin_symbol($cc_symbol), $cc_components ]; } } ## end if ( defined $cc_hash ) # Save some memory $grammar->[Marpa::R2::Internal::Grammar::CHARACTER_CLASSES] = undef; return ; } ## end sub Marpa::R2::Grammar::slif_precompute sub Marpa::R2::Grammar::show_problems { my ($grammar) = @_; my $problems = $grammar->[Marpa::R2::Internal::Grammar::PROBLEMS]; if ($problems) { my $problem_count = scalar @{$problems}; return "Grammar has $problem_count problems:\n" . ( join "\n", @{$problems} ) . "\n"; } ## end if ($problems) return "Grammar has no problems\n"; } ## end sub Marpa::R2::Grammar::show_problems # Return DSL form of symbol # Does no checking sub Marpa::R2::Grammar::symbol_dsl_form { my ( $grammar, $symbol_id ) = @_; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $symbol = $symbols->[$symbol_id]; return $symbol->[Marpa::R2::Internal::Symbol::DSL_FORM]; } # Return description of symbol # Does no checking sub Marpa::R2::Grammar::symbol_description { my ( $grammar, $symbol_id ) = @_; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $symbol = $symbols->[$symbol_id]; return $symbol->[Marpa::R2::Internal::Symbol::DESCRIPTION]; } # Return display form of symbol # Does lots of checking and makes use of alternatives. sub Marpa::R2::Grammar::symbol_in_display_form { my ( $grammar, $symbol_id ) = @_; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $symbol = $symbols->[$symbol_id]; return "" if not defined $symbol; my $text = $symbol->[Marpa::R2::Internal::Symbol::DISPLAY_FORM]; return $text if defined $text; $text = $symbol->[Marpa::R2::Internal::Symbol::DSL_FORM] // $grammar->symbol_name($symbol_id); return ($text =~ m/\s/xms) ? "<$text>" : $text; } sub Marpa::R2::Grammar::show_symbol { my ( $grammar, $symbol ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $text = q{}; my $symbol_id = $symbol->[Marpa::R2::Internal::Symbol::ID]; my $name = $grammar->symbol_name($symbol_id); $text .= "$symbol_id: $name"; my @tag_list = (); $grammar_c->symbol_is_productive($symbol_id) or push @tag_list, 'unproductive'; $grammar_c->symbol_is_accessible($symbol_id) or push @tag_list, 'inaccessible'; $grammar_c->symbol_is_nulling($symbol_id) and push @tag_list, 'nulling'; $grammar_c->symbol_is_terminal($symbol_id) and push @tag_list, 'terminal'; $text .= join q{ }, q{,}, @tag_list if scalar @tag_list; $text .= "\n"; return $text; } ## end sub Marpa::R2::Grammar::show_symbol sub Marpa::R2::Grammar::show_symbols { my ($grammar) = @_; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $text = q{}; for my $symbol_ref ( @{$symbols} ) { $text .= $grammar->show_symbol($symbol_ref); } return $text; } ## end sub Marpa::R2::Grammar::show_symbols sub Marpa::R2::Grammar::show_nulling_symbols { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; return join q{ }, sort map { $grammar->symbol_name($_) } grep { $grammar_c->symbol_is_nulling($_) } ( 0 .. $#{$symbols} ); } ## end sub Marpa::R2::Grammar::show_nulling_symbols sub Marpa::R2::Grammar::show_productive_symbols { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; return join q{ }, sort map { $grammar->symbol_name($_) } grep { $grammar_c->symbol_is_productive($_) } ( 0 .. $#{$symbols} ); } ## end sub Marpa::R2::Grammar::show_productive_symbols sub Marpa::R2::Grammar::show_accessible_symbols { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; return join q{ }, sort map { $grammar->symbol_name($_) } grep { $grammar_c->symbol_is_accessible($_) } ( 0 .. $#{$symbols} ); } ## end sub Marpa::R2::Grammar::show_accessible_symbols sub Marpa::R2::Grammar::inaccessible_symbols { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; return [ sort map { $grammar->symbol_name($_) } grep { !$grammar_c->symbol_is_accessible($_) } ( 0 .. $#{$symbols} ) ]; } ## end sub Marpa::R2::Grammar::inaccessible_symbols sub Marpa::R2::Grammar::unproductive_symbols { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; return [ sort map { $grammar->symbol_name($_) } grep { !$grammar_c->symbol_is_productive($_) } ( 0 .. $#{$symbols} ) ]; } ## end sub Marpa::R2::Grammar::unproductive_symbols sub Marpa::R2::Grammar::start_symbol { my ( $grammar ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; return $grammar_c->start_symbol(); } sub Marpa::R2::Grammar::rule_name { my ( $grammar, $rule_id ) = @_; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $rule = $rules->[$rule_id]; return "Non-existent rule $rule_id" if not defined $rule; my $name = $rule->[Marpa::R2::Internal::Rule::NAME]; return $name if defined $name; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my ( $lhs_id ) = $tracer->rule_expand($rule_id); return $grammar->symbol_name($lhs_id); } ## end sub Marpa::R2::Grammar::rule_name sub Marpa::R2::Grammar::brief_rule { my ( $grammar, $rule_id ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my ( $lhs, @rhs ) = $grammar->rule($rule_id); my $minimum = $grammar_c->sequence_min($rule_id); my $quantifier = defined $minimum ? $minimum <= 0 ? q{*} : q{+} : q{}; return ( join q{ }, "$rule_id:", $lhs, '->', @rhs ) . $quantifier; } ## end sub Marpa::R2::Grammar::brief_rule sub Marpa::R2::Grammar::show_rule { my ( $grammar, $rule ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $rule_id = $rule->[Marpa::R2::Internal::Rule::ID]; my @comment = (); $grammar_c->rule_length($rule_id) == 0 and push @comment, 'empty'; $grammar->rule_is_used($rule_id) or push @comment, '!used'; $grammar_c->rule_is_productive($rule_id) or push @comment, 'unproductive'; $grammar_c->rule_is_accessible($rule_id) or push @comment, 'inaccessible'; $rule->[Marpa::R2::Internal::Rule::DISCARD_SEPARATION] and push @comment, 'discard_sep'; my $text = $grammar->brief_rule($rule_id); if (@comment) { $text .= q{ } . ( join q{ }, q{/*}, @comment, q{*/} ); } return $text .= "\n"; } # sub show_rule sub Marpa::R2::Grammar::show_rules { my ($grammar) = @_; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $text; for my $rule ( @{$rules} ) { $text .= $grammar->show_rule($rule); } return $text; } ## end sub Marpa::R2::Grammar::show_rules # This logic deals with gaps in the rule numbering. # Currently there are none, but Libmarpa does not # guarantee this. sub Marpa::R2::Grammar::rule_ids { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; return 0 .. $grammar_c->highest_rule_id(); } ## end sub Marpa::R2::Grammar::rule_ids # This logic deals with gaps in the symbol numbering. # Currently there are none, but Libmarpa does not # guarantee this. sub Marpa::R2::Grammar::symbol_ids { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; return 0 .. $grammar_c->highest_symbol_id(); } ## end sub Marpa::R2::Grammar::rule_ids # Returns empty array if not such rule sub Marpa::R2::Grammar::rule { my ( $grammar, $rule_id ) = @_; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my @symbol_names = (); my @symbols = $tracer->rule_expand($rule_id); SYMBOL_ID: for my $symbol_id (@symbols) { ## The name of the symbols, before the BNF rewrites my $name = $symbols->[$symbol_id]->[Marpa::R2::Internal::Symbol::LEGACY_NAME] // $grammar->symbol_name($symbol_id); push @symbol_names, $name; } ## end SYMBOL_ID: for my $symbol_id (@symbol_ids) return @symbol_names; } ## end sub Marpa::R2::Grammar::rule # Internal, for use with in coordinating thin and thick # interfaces. NOT DOCUMENTED. sub Marpa::R2::Grammar::_rule_mask { my ( $grammar, $rule_id ) = @_; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $rule = $rules->[$rule_id]; return $rule->[Marpa::R2::Internal::Rule::MASK]; } ## end sub Marpa::R2::Grammar::rule # Deprecated and for removal # Used in blog post, and part of # CPAN version 2.023_008 but # never documented in any CPAN version sub Marpa::R2::Grammar::bnf_rule { goto &Marpa::R2::Grammar::rule; } ## end sub Marpa::R2::Grammar::bnf_rule sub Marpa::R2::Grammar::show_dotted_rule { my ( $grammar, $rule_id, $dot_position ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my ( $lhs, @rhs ) = $grammar->rule($rule_id); my $minimum = $grammar_c->sequence_min($rule_id); if (defined $minimum) { my $quantifier = $minimum <= 0 ? q{*} : q{+} ; $rhs[0] .= $quantifier; } $dot_position = 0 if $dot_position < 0; splice @rhs, $dot_position, 0, q{.}; return join q{ }, $lhs, q{->}, @rhs; } ## end sub Marpa::R2::Grammar::show_dotted_rule # Used by lexers to check that symbol is a terminal sub Marpa::R2::Grammar::check_terminal { my ( $grammar, $name ) = @_; return 0 if not defined $name; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $symbol_id = $grammar->[Marpa::R2::Internal::Grammar::TRACER] ->symbol_by_name($name); return 0 if not defined $symbol_id; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $symbol = $symbols->[$symbol_id]; return $grammar_c->symbol_is_terminal($symbol_id) ? 1 : 0; } ## end sub Marpa::R2::Grammar::check_terminal sub Marpa::R2::Grammar::symbol_name { my ( $grammar, $id ) = @_; my $symbol_name = $grammar->[Marpa::R2::Internal::Grammar::TRACER]->symbol_name($id); return defined $symbol_name ? $symbol_name : '[SYMBOL#' . $id . ']'; } ## end sub Marpa::R2::Grammar::symbol_name sub shadow_symbol { my ( $grammar, $symbol_id ) = @_; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $symbol = $symbols->[$symbol_id] = []; $symbol->[Marpa::R2::Internal::Symbol::ID] = $symbol_id; return $symbol; } ## end sub shadow_symbol # Create the structure which "shadows" the libmarpa rule sub shadow_rule { my ( $grammar, $rule_id ) = @_; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $new_rule = $rules->[$rule_id] = []; $new_rule->[Marpa::R2::Internal::Rule::ID] = $rule_id; return $new_rule; } ## end sub shadow_rule sub assign_symbol { my ( $grammar, $name, $options ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $symbol_id = $tracer->symbol_by_name($name); if ( defined $symbol_id ) { my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; return $symbols->[$symbol_id]; } $symbol_id = $tracer->symbol_new($name); my $symbol = shadow_symbol( $grammar, $symbol_id ); PROPERTY: for my $property ( sort keys %{$options} ) { if ( $property eq 'semantics' ) { my $value = $options->{$property}; $symbol->[Marpa::R2::Internal::Symbol::LEXEME_SEMANTICS] = $value; next PROPERTY; } if ( $property eq 'bless' ) { my $value = $options->{$property}; $symbol->[Marpa::R2::Internal::Symbol::BLESSING] = $value; next PROPERTY; } if ( $property eq 'terminal' ) { my $value = $options->{$property}; $grammar_c->symbol_is_terminal_set( $symbol_id, $value ); next PROPERTY; } if ( $property eq 'rank' ) { my $value = $options->{$property}; Marpa::R2::exception(qq{Symbol "$name": rank must be an integer}) if not Scalar::Util::looks_like_number($value) or int($value) != $value; $grammar_c->symbol_rank_set($symbol_id) = $value; next PROPERTY; } ## end if ( $property eq 'rank' ) if ( $property eq 'description' ) { my $value = $options->{$property}; $symbol->[Marpa::R2::Internal::Symbol::DESCRIPTION] = $value; next PROPERTY; } if ( $property eq 'dsl_form' ) { my $value = $options->{$property}; $symbol->[Marpa::R2::Internal::Symbol::DSL_FORM] = $value; next PROPERTY; } if ( $property eq 'legacy_name' ) { my $value = $options->{$property}; $symbol->[Marpa::R2::Internal::Symbol::LEGACY_NAME] = $value; next PROPERTY; } if ( $property eq 'display_form' ) { my $value = $options->{$property}; $symbol->[Marpa::R2::Internal::Symbol::DISPLAY_FORM] = $value; next PROPERTY; } if ( $property eq 'if_inaccessible' ) { my $value = $options->{$property}; $symbol->[Marpa::R2::Internal::Symbol::IF_INACCESSIBLE] = $value; next PROPERTY; } Marpa::R2::exception(qq{Unknown symbol property "$property"}); } ## end PROPERTY: for my $property ( keys %{$options} ) return $symbol; } ## end sub assign_symbol sub assign_user_symbol { my $grammar = shift; my $name = shift; my $options = shift; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; if ( my $type = ref $name ) { Marpa::R2::exception( "Symbol name was ref to $type; it must be a scalar string"); } if ( not $grammar->[Marpa::R2::Internal::Grammar::INTERNAL] ) { my $final_symbol = substr $name, -1; if ( $DEFAULT_SYMBOLS_RESERVED{$final_symbol} ) { Marpa::R2::exception( qq{Symbol name $name ends in "$final_symbol": that's not allowed} ); } } ## end if ( not $grammar->[Marpa::R2::Internal::Grammar::INTERNAL...]) my $symbol = assign_symbol( $grammar, $name, $options ); return $symbol; } ## end sub assign_user_symbol # add one or more rules sub add_user_rules { my ( $grammar, $rules ) = @_; my @hash_rules = (); RULE: for my $rule ( @{$rules} ) { # Translate other rule formats into hash rules my $ref_rule = ref $rule; if ( $ref_rule eq 'HASH' ) { push @hash_rules, $rule; next RULE; } if ( $ref_rule eq 'ARRAY' ) { my $arg_count = @{$rule}; if ( $arg_count > 4 or $arg_count < 1 ) { Marpa::R2::exception( "Rule has $arg_count arguments: " . join( ', ', map { defined $_ ? $_ : 'undef' } @{$rule} ) . "\n" . 'Rule must have from 1 to 4 arguments' ); } ## end if ( $arg_count > 4 or $arg_count < 1 ) my ( $lhs, $rhs, $action ) = @{$rule}; push @hash_rules, { lhs => $lhs, rhs => $rhs, action => $action, }; next RULE; } ## end if ( $ref_rule eq 'ARRAY' ) Marpa::R2::exception( 'Invalid rule: ', Data::Dumper->new( [$rule], ['Invalid_Rule'] )->Indent(2) ->Terse(1)->Maxdepth(2)->Dump, 'Rule must be ref to HASH or ARRAY' ); } # RULE for my $hash_rule (@hash_rules) { add_user_rule( $grammar, $hash_rule ); } return; } ## end sub add_user_rules sub add_user_rule { my ( $grammar, $options ) = @_; Marpa::R2::exception('Missing argument to add_user_rule') if not defined $grammar or not defined $options; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $default_rank = $grammar_c->default_rank(); my ( $lhs_name, $rhs_names, $action, $blessing ); my ( $min, $separator_name ); my $rank; my $null_ranking; my $rule_name; my $mask; my $proper_separation = 0; my $keep_separation = 0; my $description; OPTION: for my $option ( keys %{$options} ) { my $value = $options->{$option}; if ( $option eq 'name' ) { $rule_name = $value; next OPTION; } if ( $option eq 'rhs' ) { $rhs_names = $value; next OPTION } if ( $option eq 'lhs' ) { $lhs_name = $value; next OPTION } if ( $option eq 'action' ) { $action = $value; next OPTION } if ( $option eq 'bless' ) { $blessing = $value; next OPTION } if ( $option eq 'rank' ) { $rank = $value; next OPTION } if ( $option eq 'null_ranking' ) { $null_ranking = $value; next OPTION; } if ( $option eq 'min' ) { $min = $value; next OPTION } if ( $option eq 'separator' ) { $separator_name = $value; next OPTION; } if ( $option eq 'proper' ) { $proper_separation = $value; next OPTION; } if ( $option eq 'keep' ) { $keep_separation = $value; next OPTION } if ( $option eq 'mask' ) { $mask = $value; next OPTION } if ( $option eq 'description' ) { $description = $value; next OPTION } Marpa::R2::exception("Unknown user rule option: $option"); } ## end OPTION: for my $option ( keys %{$options} ) if ( defined $min and not Scalar::Util::looks_like_number($min) ) { Marpa::R2::exception( q{"min" must be undefined or a valid Perl number}); } my $stuifzand_interface = $grammar->[Marpa::R2::Internal::Grammar::INTERFACE] eq 'stuifzand'; my $grammar_is_internal = $stuifzand_interface || $grammar->[Marpa::R2::Internal::Grammar::INTERNAL]; my $lhs = $grammar_is_internal ? assign_symbol( $grammar, $lhs_name ) : assign_user_symbol( $grammar, $lhs_name ); $rhs_names //= []; my @rule_problems = (); my $rhs_ref_type = ref $rhs_names; if ( not $rhs_ref_type or $rhs_ref_type ne 'ARRAY' ) { my $problem = "RHS is not ref to ARRAY\n" . ' Type of rhs is ' . ( $rhs_ref_type ? $rhs_ref_type : 'not a ref' ) . "\n"; my $d = Data::Dumper->new( [$rhs_names], ['rhs'] ); $problem .= $d->Dump(); push @rule_problems, $problem; } ## end if ( not $rhs_ref_type or $rhs_ref_type ne 'ARRAY' ) if ( not defined $lhs_name ) { push @rule_problems, "Missing LHS\n"; } if ( defined $rank and ( not Scalar::Util::looks_like_number($rank) or int($rank) != $rank ) ) { push @rule_problems, "Rank must be undefined or an integer\n"; } ## end if ( defined $rank and ( not Scalar::Util::looks_like_number...)) $rank //= $default_rank; $null_ranking //= 'low'; if ( $null_ranking ne 'high' and $null_ranking ne 'low' ) { push @rule_problems, "Null Ranking must be undefined, 'high' or 'low'\n"; } if ( scalar @rule_problems ) { my %dump_options = %{$options}; delete $dump_options{grammar}; my $msg = ( scalar @rule_problems ) . " problem(s) in the following rule:\n"; my $d = Data::Dumper->new( [ \%dump_options ], ['rule'] ); $msg .= $d->Dump(); for my $problem_number ( 0 .. $#rule_problems ) { $msg .= 'Problem ' . ( $problem_number + 1 ) . q{: } . $rule_problems[$problem_number] . "\n"; } ## end for my $problem_number ( 0 .. $#rule_problems ) Marpa::R2::exception($msg); } ## end if ( scalar @rule_problems ) my $rhs = [ map { $grammar_is_internal ? assign_symbol( $grammar, $_ ) : assign_user_symbol( $grammar, $_ ); } @{$rhs_names} ]; # Is this is an ordinary, non-counted rule? my $is_ordinary_rule = scalar @{$rhs_names} == 0 || !defined $min; if ( defined $separator_name and $is_ordinary_rule ) { if ( defined $separator_name ) { Marpa::R2::exception( 'separator defined for rule without repetitions'); } } ## end if ( defined $separator_name and $is_ordinary_rule ) my @rhs_ids = map { $_->[Marpa::R2::Internal::Symbol::ID] } @{$rhs}; my $lhs_id = $lhs->[Marpa::R2::Internal::Symbol::ID]; if ($is_ordinary_rule) { # Capture errors $grammar_c->throw_set(0); my $ordinary_rule_id = $grammar_c->rule_new( $lhs_id, \@rhs_ids ); $grammar_c->throw_set(1); if ( $ordinary_rule_id < 0 ) { my $rule_description = rule_describe( $lhs_name, $rhs_names ); my ( $error_code, $error_string ) = $grammar_c->error(); $error_code //= -1; my $problem_description = $error_code == $Marpa::R2::Error::DUPLICATE_RULE ? 'Duplicate rule' : $error_string; Marpa::R2::exception("$problem_description: $rule_description"); } ## end if ( $ordinary_rule_id < 0 ) shadow_rule( $grammar, $ordinary_rule_id ); my $ordinary_rule = $rules->[$ordinary_rule_id]; # Only internal grammars can set a custom mask if ( not defined $mask or not $grammar_is_internal ) { $mask = [ (1) x scalar @rhs_ids ]; } $ordinary_rule->[Marpa::R2::Internal::Rule::MASK] = $mask; $ordinary_rule->[Marpa::R2::Internal::Rule::ACTION_NAME] = $action; if ( defined $rank ) { $grammar_c->rule_rank_set( $ordinary_rule_id, $rank ); } $grammar_c->rule_null_high_set( $ordinary_rule_id, ( $null_ranking eq 'high' ? 1 : 0 ) ); if ( defined $rule_name ) { $ordinary_rule->[Marpa::R2::Internal::Rule::NAME] = $rule_name; } if ( defined $blessing ) { $ordinary_rule->[Marpa::R2::Internal::Rule::BLESSING] = $blessing; } if ( defined $description ) { $ordinary_rule->[Marpa::R2::Internal::Rule::DESCRIPTION] = $description; } return; } # not defined $min Marpa::R2::exception('Only one rhs symbol allowed for counted rule') if scalar @{$rhs_names} != 1; # create the separator symbol, if we're using one my $separator; my $separator_id = -1; if ( defined $separator_name ) { $separator = $grammar_is_internal ? assign_symbol( $grammar, $separator_name ) : assign_user_symbol( $grammar, $separator_name ); $separator_id = $separator->[Marpa::R2::Internal::Symbol::ID]; } ## end if ( defined $separator_name ) $grammar_c->throw_set(0); my $original_rule_id = $grammar_c->sequence_new( $lhs_id, $rhs_ids[0], { separator => $separator_id, proper => $proper_separation, min => $min, } ); $grammar_c->throw_set(1); if ( not defined $original_rule_id or $original_rule_id < 0) { my $rule_description = rule_describe( $lhs_name, $rhs_names ); my ( $error_code, $error_string ) = $grammar_c->error(); $error_code //= -1; my $problem_description = $error_code == $Marpa::R2::Error::DUPLICATE_RULE ? 'Duplicate rule' : $error_string; Marpa::R2::exception("$problem_description: $rule_description"); } ## end if ( not defined $original_rule_id ) shadow_rule( $grammar, $original_rule_id ); # The original rule for a sequence rule is # not actually used in parsing, # but some of the rewritten sequence rules are its # semantic equivalents. my $original_rule = $rules->[$original_rule_id]; $original_rule->[Marpa::R2::Internal::Rule::ACTION_NAME] = $action; $original_rule->[Marpa::R2::Internal::Rule::DISCARD_SEPARATION] = $separator_id >= 0 && !$keep_separation; $grammar_c->rule_null_high_set( $original_rule_id, ( $null_ranking eq 'high' ? 1 : 0 ) ); $grammar_c->rule_rank_set( $original_rule_id, $rank ); if ( defined $rule_name ) { $original_rule->[Marpa::R2::Internal::Rule::NAME] = $rule_name; } if ( defined $blessing ) { $original_rule->[Marpa::R2::Internal::Rule::BLESSING] = $blessing; } if ( defined $description ) { $original_rule->[Marpa::R2::Internal::Rule::DESCRIPTION] = $description; } return; } ## end sub add_user_rule sub rule_describe { my ( $lhs_name, $rhs_names ) = @_; # wrap symbol names with whitespaces allowed by SLIF $lhs_name = "<$lhs_name>" if $lhs_name =~ / /; return "$lhs_name -> " . ( join q{ }, map { / / ? "<$_>" : $_ } @{$rhs_names} ); } ## end sub rule_describe sub set_start_symbol { my $grammar = shift; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; state $default_start_name = '[:start]'; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $default_start_id = $tracer->symbol_by_name($default_start_name); my $start_id; VALIDATE_START_NAME: { my $named_arg_start_name = $grammar->[Marpa::R2::Internal::Grammar::START_NAME]; if ( defined $named_arg_start_name and defined $start_id ) { Marpa::R2::exception( qq{Start symbol specified as '[:start]', but also with named argument\n}, qq{ You must use one or the other\n} ); } ## end if ( defined $named_arg_start_name and defined $start_id) if ( defined $named_arg_start_name ) { $start_id = $tracer->symbol_by_name($named_arg_start_name); Marpa::R2::exception( qq{Start symbol "$named_arg_start_name" not in grammar}) if not defined $start_id; last VALIDATE_START_NAME; } ## end if ( defined $named_arg_start_name ) if ( defined $default_start_id ) { $start_id = $default_start_id; $grammar->[Marpa::R2::Internal::Grammar::START_NAME] = $named_arg_start_name; last VALIDATE_START_NAME; } ## end if ( defined $default_start_id ) Marpa::R2::exception(qq{No start symbol specified in grammar\n}); } ## end VALIDATE_START_NAME: if ( not defined $grammar_c->start_symbol_set($start_id) ) { Marpa::R2::uncaught_error( $grammar_c->error() ); } return 1; } ## end sub set_start_symbol sub Marpa::R2::Grammar::error { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; return $grammar_c->error(); } # INTERNAL OK AFTER HERE _marpa_ sub Marpa::R2::Grammar::show_isy { my ( $grammar, $isy_id ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $text = q{}; my $name = $tracer->isy_name($isy_id); $text .= "$isy_id: $name"; my @tag_list = (); $grammar_c->_marpa_g_nsy_is_nulling($isy_id) and push @tag_list, 'nulling'; $text .= join q{ }, q{,}, @tag_list if scalar @tag_list; $text .= "\n"; return $text; } ## end sub Marpa::R2::Grammar::show_isy sub Marpa::R2::Grammar::show_isys { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $text = q{}; for my $isy_id ( 0 .. $grammar_c->_marpa_g_nsy_count() - 1 ) { $text .= $grammar->show_isy($isy_id); } return $text; } ## end sub Marpa::R2::Grammar::show_isys sub Marpa::R2::Grammar::brief_irl { my ( $grammar, $irl_id ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $lhs_id = $grammar_c->_marpa_g_irl_lhs($irl_id); my $text = $irl_id . ': ' . $tracer->isy_name($lhs_id) . ' ->'; if ( my $rh_length = $grammar_c->_marpa_g_irl_length($irl_id) ) { my @rhs_ids = (); for my $ix ( 0 .. $rh_length - 1 ) { push @rhs_ids, $grammar_c->_marpa_g_irl_rhs( $irl_id, $ix ); } $text .= q{ } . ( join q{ }, map { $tracer->isy_name($_) } @rhs_ids ); } ## end if ( my $rh_length = $grammar_c->_marpa_g_irl_length...) return $text; } ## end sub Marpa::R2::Grammar::brief_irl sub Marpa::R2::Grammar::show_irls { my ($grammar) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $text = q{}; for my $irl_id ( 0 .. $grammar_c->_marpa_g_irl_count() - 1 ) { $text .= $grammar->brief_irl($irl_id) . "\n"; } return $text; } ## end sub Marpa::R2::Grammar::show_irls sub Marpa::R2::Grammar::rule_is_used { my ( $grammar, $rule_id ) = @_; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; return $grammar_c->_marpa_g_rule_is_used($rule_id); } sub Marpa::R2::Grammar::show_ahms { my ( $grammar, $verbose ) = @_; return $grammar->[Marpa::R2::Internal::Grammar::TRACER] ->show_ahms($verbose); } 1; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/MetaG.pm0000444000000000000000000111122512342464707016470 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::MetaG; use 5.010; use strict; use warnings; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic(BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic package Marpa::R2::Internal::MetaG; use English qw( -no_match_vars ); sub hashed_grammar { my $hashed_metag; ## no critic(RegularExpressions::RequireDotMatchAnything) ## no critic(RegularExpressions::RequireExtendedFormatting) ## no critic(RegularExpressions::RequireLineBoundaryMatching) ## no critic(RegularExpressions::ProhibitEscapedMetacharacters) ## no critic(RegularExpressions::ProhibitComplexRegexes) ## The code after this line was automatically generated by sl_to_hash.pl ## Date: Sun Feb 23 08:51:12 2014 $hashed_metag = { 'character_classes' => { '[[\']]' => [ '[\']', '' ], '[[+-]]' => [ '[+-]', '' ], '[[,]]' => [ '[,]', '' ], '[[01]]' => [ '[01]', '' ], '[[[:alnum:]]]' => [ '[[:alnum:]]', '' ], '[[\\#]]' => [ '[\\#]', '' ], '[[\\(]]' => [ '[\\(]', '' ], '[[\\)]]' => [ '[\\)]', '' ], '[[\\*]]' => [ '[\\*]', '' ], '[[\\+]]' => [ '[\\+]', '' ], '[[\\,]]' => [ '[\\,]', '' ], '[[\\-]]' => [ '[\\-]', '' ], '[[\\:]]' => [ '[\\:]', '' ], '[[\\;]]' => [ '[\\;]', '' ], '[[\\<]]' => [ '[\\<]', '' ], '[[\\=]]' => [ '[\\=]', '' ], '[[\\>]]' => [ '[\\>]', '' ], '[[\\[]]' => [ '[\\[]', '' ], '[[\\\\]]' => [ '[\\\\]', '' ], '[[\\]]]' => [ '[\\]]', '' ], '[[\\^]]' => [ '[\\^]', '' ], '[[\\d]]' => [ '[\\d]', '' ], '[[\\s\\w]]' => [ '[\\s\\w]', '' ], '[[\\s]]' => [ '[\\s]', '' ], '[[\\w]]' => [ '[\\w]', '' ], '[[\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]]' => [ '[\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]', '' ], '[[\\{]]' => [ '[\\{]', '' ], '[[\\|]]' => [ '[\\|]', '' ], '[[\\}]]' => [ '[\\}]', '' ], '[[\\~]]' => [ '[\\~]', '' ], '[[^\'\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]]' => [ '[^\'\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]', '' ], '[[^\\x{5d}\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]]' => [ '[^\\x{5d}\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]', '' ], '[[^\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]]' => [ '[^\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]', '' ], '[[a-zA-Z]]' => [ '[a-zA-Z]', '' ], '[[a]]' => [ '[a]', '' ], '[[b]]' => [ '[b]', '' ], '[[c]]' => [ '[c]', '' ], '[[d]]' => [ '[d]', '' ], '[[e]]' => [ '[e]', '' ], '[[f]]' => [ '[f]', '' ], '[[g]]' => [ '[g]', '' ], '[[h]]' => [ '[h]', '' ], '[[i]]' => [ '[i]', '' ], '[[k]]' => [ '[k]', '' ], '[[l]]' => [ '[l]', '' ], '[[m]]' => [ '[m]', '' ], '[[n]]' => [ '[n]', '' ], '[[o]]' => [ '[o]', '' ], '[[p]]' => [ '[p]', '' ], '[[r]]' => [ '[r]', '' ], '[[s]]' => [ '[s]', '' ], '[[t]]' => [ '[t]', '' ], '[[u]]' => [ '[u]', '' ], '[[v]]' => [ '[v]', '' ], '[[w]]' => [ '[w]', '' ], '[[x]]' => [ '[x]', '' ], '[[y]]' => [ '[y]', '' ] }, 'first_lhs' => 'statements', 'lexeme_default_adverbs' => { 'action' => '[start,length,value]', 'bless' => '::name', 'forgiving' => '1' }, 'rules' => { 'G1' => [ { 'action' => '[start,length,values]', 'bless' => 'action', 'lhs' => 'action', 'mask' => [ 0, 0, 1 ], 'name' => 'action', 'rhs' => [ '[Lex-33]', '[Lex-34]', 'action name' ] }, { 'action' => '[start,length,values]', 'bless' => 'action_name', 'lhs' => 'action name', 'mask' => [ 1 ], 'name' => 'action name', 'rhs' => [ 'Perl name' ] }, { 'action' => '[start,length,values]', 'bless' => 'action_name', 'lhs' => 'action name', 'mask' => [ 1 ], 'name' => 'action name', 'rhs' => [ 'array descriptor' ] }, { 'action' => '[start,length,values]', 'bless' => 'action_name', 'lhs' => 'action name', 'mask' => [ 1 ], 'name' => 'action name', 'rhs' => [ 'reserved action name' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'action' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'blessing' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'event specification' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'group association' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'latm specification' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'left association' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'naming' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'null adverb' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'null ranking specification' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'pause specification' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'priority specification' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'proper specification' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'rank specification' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'right association' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_item', 'lhs' => 'adverb item', 'mask' => [ 1 ], 'name' => 'adverb item', 'rhs' => [ 'separator specification' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_list', 'lhs' => 'adverb list', 'mask' => [ 1 ], 'name' => 'adverb list', 'rhs' => [ 'adverb list items' ] }, { 'action' => '[start,length,values]', 'bless' => 'adverb_list_items', 'lhs' => 'adverb list items', 'min' => 0, 'name' => 'adverb list items', 'rhs' => [ 'adverb item' ] }, { 'action' => '[start,length,values]', 'bless' => 'alternative', 'lhs' => 'alternative', 'mask' => [ 1, 1 ], 'name' => 'alternative', 'rhs' => [ 'rhs', 'adverb list' ] }, { 'action' => '[start,length,values]', 'bless' => 'alternative_name', 'lhs' => 'alternative name', 'mask' => [ 1 ], 'name' => 'alternative name', 'rhs' => [ 'single quoted name' ] }, { 'action' => '[start,length,values]', 'bless' => 'alternative_name', 'lhs' => 'alternative name', 'mask' => [ 1 ], 'name' => 'alternative name', 'rhs' => [ 'standard name' ] }, { 'action' => '[start,length,values]', 'bless' => 'alternatives', 'lhs' => 'alternatives', 'min' => 1, 'name' => 'alternatives', 'proper' => '1', 'rhs' => [ 'alternative' ], 'separator' => 'op equal priority' }, { 'action' => '[start,length,values]', 'bless' => 'blessing', 'lhs' => 'blessing', 'mask' => [ 0, 0, 1 ], 'name' => 'blessing', 'rhs' => [ '[Lex-67]', '[Lex-68]', 'blessing name' ] }, { 'action' => '[start,length,values]', 'bless' => 'blessing_name', 'lhs' => 'blessing name', 'mask' => [ 1 ], 'name' => 'blessing name', 'rhs' => [ 'reserved blessing name' ] }, { 'action' => '[start,length,values]', 'bless' => 'blessing_name', 'lhs' => 'blessing name', 'mask' => [ 1 ], 'name' => 'blessing name', 'rhs' => [ 'standard name' ] }, { 'action' => '[start,length,values]', 'bless' => 'completion_event_declaration', 'lhs' => 'completion event declaration', 'mask' => [ 0, 1, 0, 0, 1 ], 'name' => 'completion event declaration', 'rhs' => [ '[Lex-13]', 'event name', '[Lex-14]', '[Lex-15]', 'symbol name' ] }, { 'action' => '[start,length,values]', 'bless' => 'current_lexer_statement', 'lhs' => 'current lexer statement', 'mask' => [ 0, 0, 0, 1 ], 'name' => 'current lexer statement', 'rhs' => [ '[Lex-22]', '[Lex-23]', '[Lex-24]', 'lexer name' ] }, { 'action' => '[start,length,values]', 'bless' => 'default_rule', 'lhs' => 'default rule', 'mask' => [ 1, 1, 1 ], 'name' => 'default rule', 'rhs' => [ '[Lex-7]', 'op declare bnf', 'adverb list' ] }, { 'action' => '[start,length,values]', 'bless' => 'discard_rule', 'lhs' => 'discard rule', 'mask' => [ 0, 0, 1 ], 'name' => 'discard rule', 'rhs' => [ '[Lex-11]', 'op declare match', 'single symbol' ] }, { 'action' => '[start,length,values]', 'bless' => 'empty_rule', 'lhs' => 'empty rule', 'mask' => [ 1, 1, 1 ], 'name' => 'empty rule', 'rhs' => [ 'lhs', 'op declare', 'adverb list' ] }, { 'action' => '[start,length,values]', 'bless' => 'event_name', 'lhs' => 'event name', 'mask' => [ 1 ], 'name' => 'event name', 'rhs' => [ 'single quoted name' ] }, { 'action' => '[start,length,values]', 'bless' => 'event_name', 'lhs' => 'event name', 'mask' => [ 1 ], 'name' => 'event name', 'rhs' => [ 'standard name' ] }, { 'action' => '[start,length,values]', 'bless' => 'event_specification', 'lhs' => 'event specification', 'mask' => [ 0, 0, 1 ], 'name' => 'event specification', 'rhs' => [ '[Lex-61]', '[Lex-62]', 'event name' ] }, { 'action' => '[start,length,values]', 'bless' => 'group_association', 'lhs' => 'group association', 'mask' => [ 0, 0, 0 ], 'name' => 'group association', 'rhs' => [ '[Lex-41]', '[Lex-42]', '[Lex-43]' ] }, { 'action' => '[start,length,values]', 'bless' => 'inaccessible_statement', 'lhs' => 'inaccessible statement', 'mask' => [ 0, 0, 1, 0, 0 ], 'name' => 'inaccessible statement', 'rhs' => [ '[Lex-25]', '[Lex-26]', 'inaccessible treatment', '[Lex-27]', '[Lex-28]' ] }, { 'action' => '[start,length,values]', 'bless' => 'inaccessible_treatment', 'lhs' => 'inaccessible treatment', 'mask' => [ 1 ], 'name' => 'inaccessible treatment', 'rhs' => [ '[Lex-29]' ] }, { 'action' => '[start,length,values]', 'bless' => 'inaccessible_treatment', 'lhs' => 'inaccessible treatment', 'mask' => [ 1 ], 'name' => 'inaccessible treatment', 'rhs' => [ '[Lex-30]' ] }, { 'action' => '[start,length,values]', 'bless' => 'inaccessible_treatment', 'lhs' => 'inaccessible treatment', 'mask' => [ 1 ], 'name' => 'inaccessible treatment', 'rhs' => [ '[Lex-31]' ] }, { 'action' => '[start,length,values]', 'bless' => 'latm_specification', 'lhs' => 'latm specification', 'mask' => [ 0, 0, 1 ], 'name' => 'latm specification', 'rhs' => [ '[Lex-63]', '[Lex-64]', 'boolean' ] }, { 'action' => '[start,length,values]', 'bless' => 'latm_specification', 'lhs' => 'latm specification', 'mask' => [ 0, 0, 1 ], 'name' => 'latm specification', 'rhs' => [ '[Lex-65]', '[Lex-66]', 'boolean' ] }, { 'action' => '[start,length,values]', 'bless' => 'left_association', 'lhs' => 'left association', 'mask' => [ 0, 0, 0 ], 'name' => 'left association', 'rhs' => [ '[Lex-35]', '[Lex-36]', '[Lex-37]' ] }, { 'action' => '[start,length,values]', 'bless' => 'lexeme_default_statement', 'lhs' => 'lexeme default statement', 'mask' => [ 0, 0, 0, 1 ], 'name' => 'lexeme default statement', 'rhs' => [ '[Lex-8]', '[Lex-9]', '[Lex-10]', 'adverb list' ] }, { 'action' => '[start,length,values]', 'bless' => 'lexeme_rule', 'lhs' => 'lexeme rule', 'mask' => [ 0, 0, 1, 1 ], 'name' => 'lexeme rule', 'rhs' => [ '[Lex-12]', 'op declare match', 'symbol', 'adverb list' ] }, { 'action' => '[start,length,values]', 'bless' => 'lexer_name', 'lhs' => 'lexer name', 'mask' => [ 1 ], 'name' => 'lexer name', 'rhs' => [ 'single quoted name' ] }, { 'action' => '[start,length,values]', 'bless' => 'lexer_name', 'lhs' => 'lexer name', 'mask' => [ 1 ], 'name' => 'lexer name', 'rhs' => [ 'standard name' ] }, { 'action' => '[start,length,values]', 'bless' => 'lhs', 'lhs' => 'lhs', 'mask' => [ 1 ], 'name' => 'lhs', 'rhs' => [ 'symbol name' ] }, { 'action' => '[start,length,values]', 'bless' => 'naming', 'lhs' => 'naming', 'mask' => [ 0, 0, 1 ], 'name' => 'naming', 'rhs' => [ '[Lex-69]', '[Lex-70]', 'alternative name' ] }, { 'action' => '[start,length,values]', 'bless' => 'null_adverb', 'lhs' => 'null adverb', 'mask' => [ 1 ], 'name' => 'null adverb', 'rhs' => [ '[Lex-32]' ] }, { 'action' => '[start,length,values]', 'bless' => 'null_ranking_constant', 'lhs' => 'null ranking constant', 'mask' => [ 1 ], 'name' => 'null ranking constant', 'rhs' => [ '[Lex-55]' ] }, { 'action' => '[start,length,values]', 'bless' => 'null_ranking_constant', 'lhs' => 'null ranking constant', 'mask' => [ 1 ], 'name' => 'null ranking constant', 'rhs' => [ '[Lex-56]' ] }, { 'action' => '[start,length,values]', 'bless' => 'null_ranking_specification', 'lhs' => 'null ranking specification', 'mask' => [ 0, 0, 1 ], 'name' => 'null ranking specification', 'rhs' => [ '[Lex-50]', '[Lex-51]', 'null ranking constant' ] }, { 'action' => '[start,length,values]', 'bless' => 'null_ranking_specification', 'lhs' => 'null ranking specification', 'mask' => [ 0, 0, 0, 1 ], 'name' => 'null ranking specification', 'rhs' => [ '[Lex-52]', '[Lex-53]', '[Lex-54]', 'null ranking constant' ] }, { 'action' => '[start,length,values]', 'bless' => 'null_statement', 'lhs' => 'null statement', 'mask' => [ 1 ], 'name' => 'null statement', 'rhs' => [ '[Lex-0]' ] }, { 'action' => '[start,length,values]', 'bless' => 'nulled_event_declaration', 'lhs' => 'nulled event declaration', 'mask' => [ 0, 1, 0, 0, 1 ], 'name' => 'nulled event declaration', 'rhs' => [ '[Lex-16]', 'event name', '[Lex-17]', '[Lex-18]', 'symbol name' ] }, { 'action' => '[start,length,values]', 'bless' => 'op_declare', 'lhs' => 'op declare', 'mask' => [ 1 ], 'name' => 'op declare', 'rhs' => [ 'op declare bnf' ] }, { 'action' => '[start,length,values]', 'bless' => 'op_declare', 'lhs' => 'op declare', 'mask' => [ 1 ], 'name' => 'op declare', 'rhs' => [ 'op declare match' ] }, { 'action' => '[start,length,values]', 'bless' => 'parenthesized_rhs_primary_list', 'lhs' => 'parenthesized rhs primary list', 'mask' => [ 0, 1, 0 ], 'name' => 'parenthesized rhs primary list', 'rhs' => [ '[Lex-71]', 'rhs primary list', '[Lex-72]' ] }, { 'action' => '[start,length,values]', 'bless' => 'pause_specification', 'lhs' => 'pause specification', 'mask' => [ 0, 0, 1 ], 'name' => 'pause specification', 'rhs' => [ '[Lex-59]', '[Lex-60]', 'before or after' ] }, { 'action' => '[start,length,values]', 'bless' => 'prediction_event_declaration', 'lhs' => 'prediction event declaration', 'mask' => [ 0, 1, 0, 0, 1 ], 'name' => 'prediction event declaration', 'rhs' => [ '[Lex-19]', 'event name', '[Lex-20]', '[Lex-21]', 'symbol name' ] }, { 'action' => '[start,length,values]', 'bless' => 'priorities', 'lhs' => 'priorities', 'min' => 1, 'name' => 'priorities', 'proper' => '1', 'rhs' => [ 'alternatives' ], 'separator' => 'op loosen' }, { 'action' => '[start,length,values]', 'bless' => 'priority_rule', 'lhs' => 'priority rule', 'mask' => [ 1, 1, 1 ], 'name' => 'priority rule', 'rhs' => [ 'lhs', 'op declare', 'priorities' ] }, { 'action' => '[start,length,values]', 'bless' => 'priority_specification', 'lhs' => 'priority specification', 'mask' => [ 0, 0, 1 ], 'name' => 'priority specification', 'rhs' => [ '[Lex-57]', '[Lex-58]', 'signed integer' ] }, { 'action' => '[start,length,values]', 'bless' => 'proper_specification', 'lhs' => 'proper specification', 'mask' => [ 0, 0, 1 ], 'name' => 'proper specification', 'rhs' => [ '[Lex-46]', '[Lex-47]', 'boolean' ] }, { 'action' => '[start,length,values]', 'bless' => 'quantified_rule', 'lhs' => 'quantified rule', 'mask' => [ 1, 1, 1, 1, 1 ], 'name' => 'quantified rule', 'rhs' => [ 'lhs', 'op declare', 'single symbol', 'quantifier', 'adverb list' ] }, { 'action' => '[start,length,values]', 'bless' => 'quantifier', 'lhs' => 'quantifier', 'mask' => [ 1 ], 'name' => 'quantifier', 'rhs' => [ '[Lex-73]' ] }, { 'action' => '[start,length,values]', 'bless' => 'quantifier', 'lhs' => 'quantifier', 'mask' => [ 1 ], 'name' => 'quantifier', 'rhs' => [ '[Lex-74]' ] }, { 'action' => '[start,length,values]', 'bless' => 'rank_specification', 'lhs' => 'rank specification', 'mask' => [ 0, 0, 1 ], 'name' => 'rank specification', 'rhs' => [ '[Lex-48]', '[Lex-49]', 'signed integer' ] }, { 'action' => '[start,length,values]', 'bless' => 'rhs', 'lhs' => 'rhs', 'min' => 1, 'name' => 'rhs', 'rhs' => [ 'rhs primary' ] }, { 'action' => '[start,length,values]', 'bless' => 'rhs_primary', 'lhs' => 'rhs primary', 'mask' => [ 1 ], 'name' => 'rhs primary', 'rhs' => [ 'parenthesized rhs primary list' ] }, { 'action' => '[start,length,values]', 'bless' => 'rhs_primary', 'lhs' => 'rhs primary', 'mask' => [ 1 ], 'name' => 'rhs primary', 'rhs' => [ 'single quoted string' ] }, { 'action' => '[start,length,values]', 'bless' => 'rhs_primary', 'lhs' => 'rhs primary', 'mask' => [ 1 ], 'name' => 'rhs primary', 'rhs' => [ 'single symbol' ] }, { 'action' => '[start,length,values]', 'bless' => 'rhs_primary_list', 'lhs' => 'rhs primary list', 'min' => 1, 'name' => 'rhs primary list', 'rhs' => [ 'rhs primary' ] }, { 'action' => '[start,length,values]', 'bless' => 'right_association', 'lhs' => 'right association', 'mask' => [ 0, 0, 0 ], 'name' => 'right association', 'rhs' => [ '[Lex-38]', '[Lex-39]', '[Lex-40]' ] }, { 'action' => '[start,length,values]', 'bless' => 'separator_specification', 'lhs' => 'separator specification', 'mask' => [ 0, 0, 1 ], 'name' => 'separator specification', 'rhs' => [ '[Lex-44]', '[Lex-45]', 'single symbol' ] }, { 'action' => '[start,length,values]', 'bless' => 'single_symbol', 'lhs' => 'single symbol', 'mask' => [ 1 ], 'name' => 'single symbol', 'rhs' => [ 'character class' ] }, { 'action' => '[start,length,values]', 'bless' => 'single_symbol', 'lhs' => 'single symbol', 'mask' => [ 1 ], 'name' => 'single symbol', 'rhs' => [ 'symbol' ] }, { 'action' => '[start,length,values]', 'bless' => 'start_rule', 'lhs' => 'start rule', 'mask' => [ 0, 0, 1 ], 'name' => 'start rule', 'rhs' => [ '[Lex-3]', 'op declare bnf', 'symbol' ] }, { 'action' => '[start,length,values]', 'bless' => 'start_rule', 'lhs' => 'start rule', 'mask' => [ 0, 0, 0, 1 ], 'name' => 'start rule', 'rhs' => [ '[Lex-4]', '[Lex-5]', '[Lex-6]', 'symbol' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'completion event declaration' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'current lexer statement' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'default rule' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'discard rule' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'empty rule' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'inaccessible statement' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'lexeme default statement' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'lexeme rule' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'null statement' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'nulled event declaration' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'prediction event declaration' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'priority rule' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'quantified rule' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'start rule' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement', 'lhs' => 'statement', 'mask' => [ 1 ], 'name' => 'statement', 'rhs' => [ 'statement group' ] }, { 'action' => '[start,length,values]', 'bless' => 'statement_group', 'lhs' => 'statement group', 'mask' => [ 0, 1, 1 ], 'name' => 'statement group', 'rhs' => [ '[Lex-1]', 'statements', '[Lex-2]' ] }, { 'action' => '[start,length,values]', 'bless' => 'statements', 'lhs' => 'statements', 'min' => 1, 'name' => 'statements', 'rhs' => [ 'statement' ] }, { 'action' => '[start,length,values]', 'bless' => 'symbol', 'lhs' => 'symbol', 'mask' => [ 1 ], 'name' => 'symbol', 'rhs' => [ 'symbol name' ] }, { 'action' => '[start,length,values]', 'bless' => 'symbol_name', 'lhs' => 'symbol name', 'mask' => [ 1 ], 'name' => 'symbol name', 'rhs' => [ 'bare name' ] }, { 'action' => '[start,length,values]', 'bless' => 'symbol_name', 'lhs' => 'symbol name', 'mask' => [ 1 ], 'name' => 'symbol name', 'rhs' => [ 'bracketed name' ] } ], 'L0' => [ { 'lhs' => 'Perl identifier', 'min' => 1, 'rhs' => [ '[[\\w]]' ] }, { 'lhs' => 'Perl name', 'min' => 1, 'proper' => '1', 'rhs' => [ 'Perl identifier' ], 'separator' => 'double colon' }, { 'description' => 'Discard rule for ', 'lhs' => '[:discard]', 'rhs' => [ 'hash comment' ] }, { 'description' => 'Discard rule for ', 'lhs' => '[:discard]', 'rhs' => [ 'whitespace' ] }, { 'description' => 'Internal rule for single-quoted string \';\'', 'lhs' => '[Lex-0]', 'mask' => [ 1 ], 'rhs' => [ '[[\\;]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=\'', 'lhs' => '[Lex-10]', 'mask' => [ 1 ], 'rhs' => [ '[[\\=]]' ] }, { 'description' => 'Internal rule for single-quoted string \':discard\'', 'lhs' => '[Lex-11]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[\\:]]', '[[d]]', '[[i]]', '[[s]]', '[[c]]', '[[a]]', '[[r]]', '[[d]]' ] }, { 'description' => 'Internal rule for single-quoted string \':lexeme\'', 'lhs' => '[Lex-12]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[\\:]]', '[[l]]', '[[e]]', '[[x]]', '[[e]]', '[[m]]', '[[e]]' ] }, { 'description' => 'Internal rule for single-quoted string \'event\'', 'lhs' => '[Lex-13]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[e]]', '[[v]]', '[[e]]', '[[n]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=\'', 'lhs' => '[Lex-14]', 'mask' => [ 1 ], 'rhs' => [ '[[\\=]]' ] }, { 'description' => 'Internal rule for single-quoted string \'completed\'', 'lhs' => '[Lex-15]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[c]]', '[[o]]', '[[m]]', '[[p]]', '[[l]]', '[[e]]', '[[t]]', '[[e]]', '[[d]]' ] }, { 'description' => 'Internal rule for single-quoted string \'event\'', 'lhs' => '[Lex-16]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[e]]', '[[v]]', '[[e]]', '[[n]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=\'', 'lhs' => '[Lex-17]', 'mask' => [ 1 ], 'rhs' => [ '[[\\=]]' ] }, { 'description' => 'Internal rule for single-quoted string \'nulled\'', 'lhs' => '[Lex-18]', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[n]]', '[[u]]', '[[l]]', '[[l]]', '[[e]]', '[[d]]' ] }, { 'description' => 'Internal rule for single-quoted string \'event\'', 'lhs' => '[Lex-19]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[e]]', '[[v]]', '[[e]]', '[[n]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'{\'', 'lhs' => '[Lex-1]', 'mask' => [ 1 ], 'rhs' => [ '[[\\{]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=\'', 'lhs' => '[Lex-20]', 'mask' => [ 1 ], 'rhs' => [ '[[\\=]]' ] }, { 'description' => 'Internal rule for single-quoted string \'predicted\'', 'lhs' => '[Lex-21]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[p]]', '[[r]]', '[[e]]', '[[d]]', '[[i]]', '[[c]]', '[[t]]', '[[e]]', '[[d]]' ] }, { 'description' => 'Internal rule for single-quoted string \'current\'', 'lhs' => '[Lex-22]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[c]]', '[[u]]', '[[r]]', '[[r]]', '[[e]]', '[[n]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'lexer\'', 'lhs' => '[Lex-23]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[l]]', '[[e]]', '[[x]]', '[[e]]', '[[r]]' ] }, { 'description' => 'Internal rule for single-quoted string \'is\'', 'lhs' => '[Lex-24]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[i]]', '[[s]]' ] }, { 'description' => 'Internal rule for single-quoted string \'inaccessible\'', 'lhs' => '[Lex-25]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[i]]', '[[n]]', '[[a]]', '[[c]]', '[[c]]', '[[e]]', '[[s]]', '[[s]]', '[[i]]', '[[b]]', '[[l]]', '[[e]]' ] }, { 'description' => 'Internal rule for single-quoted string \'is\'', 'lhs' => '[Lex-26]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[i]]', '[[s]]' ] }, { 'description' => 'Internal rule for single-quoted string \'by\'', 'lhs' => '[Lex-27]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[b]]', '[[y]]' ] }, { 'description' => 'Internal rule for single-quoted string \'default\'', 'lhs' => '[Lex-28]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[d]]', '[[e]]', '[[f]]', '[[a]]', '[[u]]', '[[l]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'warn\'', 'lhs' => '[Lex-29]', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[w]]', '[[a]]', '[[r]]', '[[n]]' ] }, { 'description' => 'Internal rule for single-quoted string \'}\'', 'lhs' => '[Lex-2]', 'mask' => [ 1 ], 'rhs' => [ '[[\\}]]' ] }, { 'description' => 'Internal rule for single-quoted string \'ok\'', 'lhs' => '[Lex-30]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[o]]', '[[k]]' ] }, { 'description' => 'Internal rule for single-quoted string \'fatal\'', 'lhs' => '[Lex-31]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[f]]', '[[a]]', '[[t]]', '[[a]]', '[[l]]' ] }, { 'description' => 'Internal rule for single-quoted string \',\'', 'lhs' => '[Lex-32]', 'mask' => [ 1 ], 'rhs' => [ '[[\\,]]' ] }, { 'description' => 'Internal rule for single-quoted string \'action\'', 'lhs' => '[Lex-33]', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[a]]', '[[c]]', '[[t]]', '[[i]]', '[[o]]', '[[n]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-34]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'assoc\'', 'lhs' => '[Lex-35]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[a]]', '[[s]]', '[[s]]', '[[o]]', '[[c]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-36]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'left\'', 'lhs' => '[Lex-37]', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[l]]', '[[e]]', '[[f]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'assoc\'', 'lhs' => '[Lex-38]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[a]]', '[[s]]', '[[s]]', '[[o]]', '[[c]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-39]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \':start\'', 'lhs' => '[Lex-3]', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[\\:]]', '[[s]]', '[[t]]', '[[a]]', '[[r]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'right\'', 'lhs' => '[Lex-40]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[r]]', '[[i]]', '[[g]]', '[[h]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'assoc\'', 'lhs' => '[Lex-41]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[a]]', '[[s]]', '[[s]]', '[[o]]', '[[c]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-42]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'group\'', 'lhs' => '[Lex-43]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[g]]', '[[r]]', '[[o]]', '[[u]]', '[[p]]' ] }, { 'description' => 'Internal rule for single-quoted string \'separator\'', 'lhs' => '[Lex-44]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[s]]', '[[e]]', '[[p]]', '[[a]]', '[[r]]', '[[a]]', '[[t]]', '[[o]]', '[[r]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-45]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'proper\'', 'lhs' => '[Lex-46]', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[p]]', '[[r]]', '[[o]]', '[[p]]', '[[e]]', '[[r]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-47]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'rank\'', 'lhs' => '[Lex-48]', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[r]]', '[[a]]', '[[n]]', '[[k]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-49]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'start\'', 'lhs' => '[Lex-4]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[s]]', '[[t]]', '[[a]]', '[[r]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'null-ranking\'', 'lhs' => '[Lex-50]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[n]]', '[[u]]', '[[l]]', '[[l]]', '[[\\-]]', '[[r]]', '[[a]]', '[[n]]', '[[k]]', '[[i]]', '[[n]]', '[[g]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-51]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'null\'', 'lhs' => '[Lex-52]', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[n]]', '[[u]]', '[[l]]', '[[l]]' ] }, { 'description' => 'Internal rule for single-quoted string \'rank\'', 'lhs' => '[Lex-53]', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[r]]', '[[a]]', '[[n]]', '[[k]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-54]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'low\'', 'lhs' => '[Lex-55]', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[l]]', '[[o]]', '[[w]]' ] }, { 'description' => 'Internal rule for single-quoted string \'high\'', 'lhs' => '[Lex-56]', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[h]]', '[[i]]', '[[g]]', '[[h]]' ] }, { 'description' => 'Internal rule for single-quoted string \'priority\'', 'lhs' => '[Lex-57]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[p]]', '[[r]]', '[[i]]', '[[o]]', '[[r]]', '[[i]]', '[[t]]', '[[y]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-58]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'pause\'', 'lhs' => '[Lex-59]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[p]]', '[[a]]', '[[u]]', '[[s]]', '[[e]]' ] }, { 'description' => 'Internal rule for single-quoted string \'symbol\'', 'lhs' => '[Lex-5]', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[s]]', '[[y]]', '[[m]]', '[[b]]', '[[o]]', '[[l]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-60]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'event\'', 'lhs' => '[Lex-61]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[e]]', '[[v]]', '[[e]]', '[[n]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-62]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'forgiving\'', 'lhs' => '[Lex-63]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[f]]', '[[o]]', '[[r]]', '[[g]]', '[[i]]', '[[v]]', '[[i]]', '[[n]]', '[[g]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-64]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'latm\'', 'lhs' => '[Lex-65]', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[l]]', '[[a]]', '[[t]]', '[[m]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-66]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'bless\'', 'lhs' => '[Lex-67]', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[b]]', '[[l]]', '[[e]]', '[[s]]', '[[s]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-68]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'name\'', 'lhs' => '[Lex-69]', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[n]]', '[[a]]', '[[m]]', '[[e]]' ] }, { 'description' => 'Internal rule for single-quoted string \'is\'', 'lhs' => '[Lex-6]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[i]]', '[[s]]' ] }, { 'description' => 'Internal rule for single-quoted string \'=>\'', 'lhs' => '[Lex-70]', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\=]]', '[[\\>]]' ] }, { 'description' => 'Internal rule for single-quoted string \'(\'', 'lhs' => '[Lex-71]', 'mask' => [ 1 ], 'rhs' => [ '[[\\(]]' ] }, { 'description' => 'Internal rule for single-quoted string \')\'', 'lhs' => '[Lex-72]', 'mask' => [ 1 ], 'rhs' => [ '[[\\)]]' ] }, { 'description' => 'Internal rule for single-quoted string \'*\'', 'lhs' => '[Lex-73]', 'mask' => [ 1 ], 'rhs' => [ '[[\\*]]' ] }, { 'description' => 'Internal rule for single-quoted string \'+\'', 'lhs' => '[Lex-74]', 'mask' => [ 1 ], 'rhs' => [ '[[\\+]]' ] }, { 'description' => 'Internal rule for single-quoted string \':default\'', 'lhs' => '[Lex-7]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[\\:]]', '[[d]]', '[[e]]', '[[f]]', '[[a]]', '[[u]]', '[[l]]', '[[t]]' ] }, { 'description' => 'Internal rule for single-quoted string \'lexeme\'', 'lhs' => '[Lex-8]', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[l]]', '[[e]]', '[[x]]', '[[e]]', '[[m]]', '[[e]]' ] }, { 'description' => 'Internal rule for single-quoted string \'default\'', 'lhs' => '[Lex-9]', 'mask' => [ 1, 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[d]]', '[[e]]', '[[f]]', '[[a]]', '[[u]]', '[[l]]', '[[t]]' ] }, { 'lhs' => 'array descriptor', 'mask' => [ 1, 1, 1 ], 'rhs' => [ 'array descriptor left bracket', 'result item descriptor list', 'array descriptor right bracket' ] }, { 'lhs' => 'array descriptor left bracket', 'mask' => [ 1 ], 'rhs' => [ '[[\\[]]' ] }, { 'lhs' => 'array descriptor left bracket', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\[]]', 'whitespace' ] }, { 'lhs' => 'array descriptor right bracket', 'mask' => [ 1 ], 'rhs' => [ '[[\\]]]' ] }, { 'lhs' => 'array descriptor right bracket', 'mask' => [ 1, 1 ], 'rhs' => [ 'whitespace', '[[\\]]]' ] }, { 'lhs' => 'bare name', 'min' => 1, 'rhs' => [ '[[\\w]]' ] }, { 'lhs' => 'before or after', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[a]]', '[[f]]', '[[t]]', '[[e]]', '[[r]]' ] }, { 'lhs' => 'before or after', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[b]]', '[[e]]', '[[f]]', '[[o]]', '[[r]]', '[[e]]' ] }, { 'lhs' => 'boolean', 'mask' => [ 1 ], 'rhs' => [ '[[01]]' ] }, { 'lhs' => 'bracketed name', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[\\<]]', 'bracketed name string', '[[\\>]]' ] }, { 'lhs' => 'bracketed name string', 'min' => 1, 'rhs' => [ '[[\\s\\w]]' ] }, { 'lhs' => 'cc element', 'mask' => [ 1 ], 'rhs' => [ 'escaped cc character' ] }, { 'lhs' => 'cc element', 'mask' => [ 1 ], 'rhs' => [ 'negated posix char class' ] }, { 'lhs' => 'cc element', 'mask' => [ 1 ], 'rhs' => [ 'posix char class' ] }, { 'lhs' => 'cc element', 'mask' => [ 1 ], 'rhs' => [ 'safe cc character' ] }, { 'lhs' => 'cc elements', 'min' => 1, 'rhs' => [ 'cc element' ] }, { 'lhs' => 'character class', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[\\[]]', 'cc elements', '[[\\]]]', 'character class modifiers' ] }, { 'lhs' => 'character class modifier', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\:]]', '[[i]]' ] }, { 'lhs' => 'character class modifier', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[\\:]]', '[[i]]', '[[c]]' ] }, { 'lhs' => 'character class modifiers', 'min' => 0, 'rhs' => [ 'character class modifier' ] }, { 'lhs' => 'double colon', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\:]]', '[[\\:]]' ] }, { 'lhs' => 'escaped cc character', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\\\]]', 'horizontal character' ] }, { 'lhs' => 'hash comment', 'mask' => [ 1 ], 'rhs' => [ 'terminated hash comment' ] }, { 'lhs' => 'hash comment', 'mask' => [ 1 ], 'rhs' => [ 'unterminated final hash comment' ] }, { 'lhs' => 'hash comment body', 'min' => 0, 'rhs' => [ 'hash comment char' ] }, { 'lhs' => 'hash comment char', 'mask' => [ 1 ], 'rhs' => [ '[[^\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]]' ] }, { 'lhs' => 'horizontal character', 'mask' => [ 1 ], 'rhs' => [ '[[^\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]]' ] }, { 'lhs' => 'integer', 'min' => 1, 'rhs' => [ '[[\\d]]' ] }, { 'lhs' => 'negated posix char class', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[\\[]]', '[[\\:]]', '[[\\^]]', 'posix char class name', '[[\\:]]', '[[\\]]]' ] }, { 'lhs' => 'one or more word characters', 'min' => 1, 'rhs' => [ '[[\\w]]' ] }, { 'lhs' => 'op declare bnf', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[\\:]]', '[[\\:]]', '[[\\=]]' ] }, { 'lhs' => 'op declare match', 'mask' => [ 1 ], 'rhs' => [ '[[\\~]]' ] }, { 'lhs' => 'op equal priority', 'mask' => [ 1 ], 'rhs' => [ '[[\\|]]' ] }, { 'lhs' => 'op loosen', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\|]]', '[[\\|]]' ] }, { 'lhs' => 'posix char class', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[\\[]]', '[[\\:]]', 'posix char class name', '[[\\:]]', '[[\\]]]' ] }, { 'lhs' => 'posix char class name', 'min' => 1, 'rhs' => [ '[[[:alnum:]]]' ] }, { 'lhs' => 'reserved action name', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[\\:]]', '[[\\:]]', 'one or more word characters' ] }, { 'lhs' => 'reserved blessing name', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[\\:]]', '[[\\:]]', 'one or more word characters' ] }, { 'lhs' => 'result item descriptor', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[l]]', '[[h]]', '[[s]]' ] }, { 'lhs' => 'result item descriptor', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[n]]', '[[a]]', '[[m]]', '[[e]]' ] }, { 'lhs' => 'result item descriptor', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[r]]', '[[u]]', '[[l]]', '[[e]]' ] }, { 'lhs' => 'result item descriptor', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[s]]', '[[t]]', '[[a]]', '[[r]]', '[[t]]' ] }, { 'lhs' => 'result item descriptor', 'mask' => [ 1, 1, 1, 1, 1 ], 'rhs' => [ '[[v]]', '[[a]]', '[[l]]', '[[u]]', '[[e]]' ] }, { 'lhs' => 'result item descriptor', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[l]]', '[[e]]', '[[n]]', '[[g]]', '[[t]]', '[[h]]' ] }, { 'lhs' => 'result item descriptor', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[s]]', '[[y]]', '[[m]]', '[[b]]', '[[o]]', '[[l]]' ] }, { 'lhs' => 'result item descriptor', 'mask' => [ 1, 1, 1, 1, 1, 1 ], 'rhs' => [ '[[v]]', '[[a]]', '[[l]]', '[[u]]', '[[e]]', '[[s]]' ] }, { 'lhs' => 'result item descriptor list', 'min' => 0, 'rhs' => [ 'result item descriptor' ], 'separator' => 'result item descriptor separator' }, { 'lhs' => 'result item descriptor separator', 'mask' => [ 1 ], 'rhs' => [ '[[,]]' ] }, { 'lhs' => 'result item descriptor separator', 'mask' => [ 1, 1 ], 'rhs' => [ '[[,]]', 'whitespace' ] }, { 'lhs' => 'safe cc character', 'mask' => [ 1 ], 'rhs' => [ '[[^\\x{5d}\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]]' ] }, { 'lhs' => 'sign', 'mask' => [ 1 ], 'rhs' => [ '[[+-]]' ] }, { 'lhs' => 'signed integer', 'mask' => [ 1 ], 'rhs' => [ 'integer' ] }, { 'lhs' => 'signed integer', 'mask' => [ 1, 1 ], 'rhs' => [ 'sign', 'integer' ] }, { 'lhs' => 'single quoted name', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[\']]', 'string without single quote or vertical space', '[[\']]' ] }, { 'lhs' => 'single quoted string', 'mask' => [ 1, 1, 1, 1 ], 'rhs' => [ '[[\']]', 'string without single quote or vertical space', '[[\']]', 'character class modifiers' ] }, { 'lhs' => 'standard name', 'mask' => [ 1, 1 ], 'rhs' => [ '[[a-zA-Z]]', 'zero or more word characters' ] }, { 'lhs' => 'string without single quote or vertical space', 'min' => 1, 'rhs' => [ '[[^\'\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]]' ] }, { 'lhs' => 'terminated hash comment', 'mask' => [ 1, 1, 1 ], 'rhs' => [ '[[\\#]]', 'hash comment body', 'vertical space char' ] }, { 'lhs' => 'unterminated final hash comment', 'mask' => [ 1, 1 ], 'rhs' => [ '[[\\#]]', 'hash comment body' ] }, { 'lhs' => 'vertical space char', 'mask' => [ 1 ], 'rhs' => [ '[[\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]]' ] }, { 'lhs' => 'whitespace', 'min' => 1, 'rhs' => [ '[[\\s]]' ] }, { 'lhs' => 'zero or more word characters', 'min' => 0, 'rhs' => [ '[[\\w]]' ] } ] }, 'start_lhs' => 'statements', 'symbols' => { 'G1' => { '[Lex-0]' => { 'description' => 'Internal lexical symbol for "\';\'"', 'display_form' => '\';\'', 'dsl_form' => '\';\'' }, '[Lex-10]' => { 'description' => 'Internal lexical symbol for "\'=\'"', 'display_form' => '\'=\'', 'dsl_form' => '\'=\'' }, '[Lex-11]' => { 'description' => 'Internal lexical symbol for "\':discard\'"', 'display_form' => '\':discard\'', 'dsl_form' => '\':discard\'' }, '[Lex-12]' => { 'description' => 'Internal lexical symbol for "\':lexeme\'"', 'display_form' => '\':lexeme\'', 'dsl_form' => '\':lexeme\'' }, '[Lex-13]' => { 'description' => 'Internal lexical symbol for "\'event\'"', 'display_form' => '\'event\'', 'dsl_form' => '\'event\'' }, '[Lex-14]' => { 'description' => 'Internal lexical symbol for "\'=\'"', 'display_form' => '\'=\'', 'dsl_form' => '\'=\'' }, '[Lex-15]' => { 'description' => 'Internal lexical symbol for "\'completed\'"', 'display_form' => '\'completed\'', 'dsl_form' => '\'completed\'' }, '[Lex-16]' => { 'description' => 'Internal lexical symbol for "\'event\'"', 'display_form' => '\'event\'', 'dsl_form' => '\'event\'' }, '[Lex-17]' => { 'description' => 'Internal lexical symbol for "\'=\'"', 'display_form' => '\'=\'', 'dsl_form' => '\'=\'' }, '[Lex-18]' => { 'description' => 'Internal lexical symbol for "\'nulled\'"', 'display_form' => '\'nulled\'', 'dsl_form' => '\'nulled\'' }, '[Lex-19]' => { 'description' => 'Internal lexical symbol for "\'event\'"', 'display_form' => '\'event\'', 'dsl_form' => '\'event\'' }, '[Lex-1]' => { 'description' => 'Internal lexical symbol for "\'{\'"', 'display_form' => '\'{\'', 'dsl_form' => '\'{\'' }, '[Lex-20]' => { 'description' => 'Internal lexical symbol for "\'=\'"', 'display_form' => '\'=\'', 'dsl_form' => '\'=\'' }, '[Lex-21]' => { 'description' => 'Internal lexical symbol for "\'predicted\'"', 'display_form' => '\'predicted\'', 'dsl_form' => '\'predicted\'' }, '[Lex-22]' => { 'description' => 'Internal lexical symbol for "\'current\'"', 'display_form' => '\'current\'', 'dsl_form' => '\'current\'' }, '[Lex-23]' => { 'description' => 'Internal lexical symbol for "\'lexer\'"', 'display_form' => '\'lexer\'', 'dsl_form' => '\'lexer\'' }, '[Lex-24]' => { 'description' => 'Internal lexical symbol for "\'is\'"', 'display_form' => '\'is\'', 'dsl_form' => '\'is\'' }, '[Lex-25]' => { 'description' => 'Internal lexical symbol for "\'inaccessible\'"', 'display_form' => '\'inaccessible\'', 'dsl_form' => '\'inaccessible\'' }, '[Lex-26]' => { 'description' => 'Internal lexical symbol for "\'is\'"', 'display_form' => '\'is\'', 'dsl_form' => '\'is\'' }, '[Lex-27]' => { 'description' => 'Internal lexical symbol for "\'by\'"', 'display_form' => '\'by\'', 'dsl_form' => '\'by\'' }, '[Lex-28]' => { 'description' => 'Internal lexical symbol for "\'default\'"', 'display_form' => '\'default\'', 'dsl_form' => '\'default\'' }, '[Lex-29]' => { 'description' => 'Internal lexical symbol for "\'warn\'"', 'display_form' => '\'warn\'', 'dsl_form' => '\'warn\'' }, '[Lex-2]' => { 'description' => 'Internal lexical symbol for "\'}\'"', 'display_form' => '\'}\'', 'dsl_form' => '\'}\'' }, '[Lex-30]' => { 'description' => 'Internal lexical symbol for "\'ok\'"', 'display_form' => '\'ok\'', 'dsl_form' => '\'ok\'' }, '[Lex-31]' => { 'description' => 'Internal lexical symbol for "\'fatal\'"', 'display_form' => '\'fatal\'', 'dsl_form' => '\'fatal\'' }, '[Lex-32]' => { 'description' => 'Internal lexical symbol for "\',\'"', 'display_form' => '\',\'', 'dsl_form' => '\',\'' }, '[Lex-33]' => { 'description' => 'Internal lexical symbol for "\'action\'"', 'display_form' => '\'action\'', 'dsl_form' => '\'action\'' }, '[Lex-34]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-35]' => { 'description' => 'Internal lexical symbol for "\'assoc\'"', 'display_form' => '\'assoc\'', 'dsl_form' => '\'assoc\'' }, '[Lex-36]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-37]' => { 'description' => 'Internal lexical symbol for "\'left\'"', 'display_form' => '\'left\'', 'dsl_form' => '\'left\'' }, '[Lex-38]' => { 'description' => 'Internal lexical symbol for "\'assoc\'"', 'display_form' => '\'assoc\'', 'dsl_form' => '\'assoc\'' }, '[Lex-39]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-3]' => { 'description' => 'Internal lexical symbol for "\':start\'"', 'display_form' => '\':start\'', 'dsl_form' => '\':start\'' }, '[Lex-40]' => { 'description' => 'Internal lexical symbol for "\'right\'"', 'display_form' => '\'right\'', 'dsl_form' => '\'right\'' }, '[Lex-41]' => { 'description' => 'Internal lexical symbol for "\'assoc\'"', 'display_form' => '\'assoc\'', 'dsl_form' => '\'assoc\'' }, '[Lex-42]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-43]' => { 'description' => 'Internal lexical symbol for "\'group\'"', 'display_form' => '\'group\'', 'dsl_form' => '\'group\'' }, '[Lex-44]' => { 'description' => 'Internal lexical symbol for "\'separator\'"', 'display_form' => '\'separator\'', 'dsl_form' => '\'separator\'' }, '[Lex-45]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-46]' => { 'description' => 'Internal lexical symbol for "\'proper\'"', 'display_form' => '\'proper\'', 'dsl_form' => '\'proper\'' }, '[Lex-47]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-48]' => { 'description' => 'Internal lexical symbol for "\'rank\'"', 'display_form' => '\'rank\'', 'dsl_form' => '\'rank\'' }, '[Lex-49]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-4]' => { 'description' => 'Internal lexical symbol for "\'start\'"', 'display_form' => '\'start\'', 'dsl_form' => '\'start\'' }, '[Lex-50]' => { 'description' => 'Internal lexical symbol for "\'null-ranking\'"', 'display_form' => '\'null-ranking\'', 'dsl_form' => '\'null-ranking\'' }, '[Lex-51]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-52]' => { 'description' => 'Internal lexical symbol for "\'null\'"', 'display_form' => '\'null\'', 'dsl_form' => '\'null\'' }, '[Lex-53]' => { 'description' => 'Internal lexical symbol for "\'rank\'"', 'display_form' => '\'rank\'', 'dsl_form' => '\'rank\'' }, '[Lex-54]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-55]' => { 'description' => 'Internal lexical symbol for "\'low\'"', 'display_form' => '\'low\'', 'dsl_form' => '\'low\'' }, '[Lex-56]' => { 'description' => 'Internal lexical symbol for "\'high\'"', 'display_form' => '\'high\'', 'dsl_form' => '\'high\'' }, '[Lex-57]' => { 'description' => 'Internal lexical symbol for "\'priority\'"', 'display_form' => '\'priority\'', 'dsl_form' => '\'priority\'' }, '[Lex-58]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-59]' => { 'description' => 'Internal lexical symbol for "\'pause\'"', 'display_form' => '\'pause\'', 'dsl_form' => '\'pause\'' }, '[Lex-5]' => { 'description' => 'Internal lexical symbol for "\'symbol\'"', 'display_form' => '\'symbol\'', 'dsl_form' => '\'symbol\'' }, '[Lex-60]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-61]' => { 'description' => 'Internal lexical symbol for "\'event\'"', 'display_form' => '\'event\'', 'dsl_form' => '\'event\'' }, '[Lex-62]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-63]' => { 'description' => 'Internal lexical symbol for "\'forgiving\'"', 'display_form' => '\'forgiving\'', 'dsl_form' => '\'forgiving\'' }, '[Lex-64]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-65]' => { 'description' => 'Internal lexical symbol for "\'latm\'"', 'display_form' => '\'latm\'', 'dsl_form' => '\'latm\'' }, '[Lex-66]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-67]' => { 'description' => 'Internal lexical symbol for "\'bless\'"', 'display_form' => '\'bless\'', 'dsl_form' => '\'bless\'' }, '[Lex-68]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-69]' => { 'description' => 'Internal lexical symbol for "\'name\'"', 'display_form' => '\'name\'', 'dsl_form' => '\'name\'' }, '[Lex-6]' => { 'description' => 'Internal lexical symbol for "\'is\'"', 'display_form' => '\'is\'', 'dsl_form' => '\'is\'' }, '[Lex-70]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-71]' => { 'description' => 'Internal lexical symbol for "\'(\'"', 'display_form' => '\'(\'', 'dsl_form' => '\'(\'' }, '[Lex-72]' => { 'description' => 'Internal lexical symbol for "\')\'"', 'display_form' => '\')\'', 'dsl_form' => '\')\'' }, '[Lex-73]' => { 'description' => 'Internal lexical symbol for "\'*\'"', 'display_form' => '\'*\'', 'dsl_form' => '\'*\'' }, '[Lex-74]' => { 'description' => 'Internal lexical symbol for "\'+\'"', 'display_form' => '\'+\'', 'dsl_form' => '\'+\'' }, '[Lex-7]' => { 'description' => 'Internal lexical symbol for "\':default\'"', 'display_form' => '\':default\'', 'dsl_form' => '\':default\'' }, '[Lex-8]' => { 'description' => 'Internal lexical symbol for "\'lexeme\'"', 'display_form' => '\'lexeme\'', 'dsl_form' => '\'lexeme\'' }, '[Lex-9]' => { 'description' => 'Internal lexical symbol for "\'default\'"', 'display_form' => '\'default\'', 'dsl_form' => '\'default\'' } }, 'L' => { '[:discard]' => { 'description' => 'Internal LHS for lexer "L0" discard', 'display_form' => ':discard' }, '[Lex-0]' => { 'description' => 'Internal lexical symbol for "\';\'"', 'display_form' => '\';\'', 'dsl_form' => '\';\'' }, '[Lex-10]' => { 'description' => 'Internal lexical symbol for "\'=\'"', 'display_form' => '\'=\'', 'dsl_form' => '\'=\'' }, '[Lex-11]' => { 'description' => 'Internal lexical symbol for "\':discard\'"', 'display_form' => '\':discard\'', 'dsl_form' => '\':discard\'' }, '[Lex-12]' => { 'description' => 'Internal lexical symbol for "\':lexeme\'"', 'display_form' => '\':lexeme\'', 'dsl_form' => '\':lexeme\'' }, '[Lex-13]' => { 'description' => 'Internal lexical symbol for "\'event\'"', 'display_form' => '\'event\'', 'dsl_form' => '\'event\'' }, '[Lex-14]' => { 'description' => 'Internal lexical symbol for "\'=\'"', 'display_form' => '\'=\'', 'dsl_form' => '\'=\'' }, '[Lex-15]' => { 'description' => 'Internal lexical symbol for "\'completed\'"', 'display_form' => '\'completed\'', 'dsl_form' => '\'completed\'' }, '[Lex-16]' => { 'description' => 'Internal lexical symbol for "\'event\'"', 'display_form' => '\'event\'', 'dsl_form' => '\'event\'' }, '[Lex-17]' => { 'description' => 'Internal lexical symbol for "\'=\'"', 'display_form' => '\'=\'', 'dsl_form' => '\'=\'' }, '[Lex-18]' => { 'description' => 'Internal lexical symbol for "\'nulled\'"', 'display_form' => '\'nulled\'', 'dsl_form' => '\'nulled\'' }, '[Lex-19]' => { 'description' => 'Internal lexical symbol for "\'event\'"', 'display_form' => '\'event\'', 'dsl_form' => '\'event\'' }, '[Lex-1]' => { 'description' => 'Internal lexical symbol for "\'{\'"', 'display_form' => '\'{\'', 'dsl_form' => '\'{\'' }, '[Lex-20]' => { 'description' => 'Internal lexical symbol for "\'=\'"', 'display_form' => '\'=\'', 'dsl_form' => '\'=\'' }, '[Lex-21]' => { 'description' => 'Internal lexical symbol for "\'predicted\'"', 'display_form' => '\'predicted\'', 'dsl_form' => '\'predicted\'' }, '[Lex-22]' => { 'description' => 'Internal lexical symbol for "\'current\'"', 'display_form' => '\'current\'', 'dsl_form' => '\'current\'' }, '[Lex-23]' => { 'description' => 'Internal lexical symbol for "\'lexer\'"', 'display_form' => '\'lexer\'', 'dsl_form' => '\'lexer\'' }, '[Lex-24]' => { 'description' => 'Internal lexical symbol for "\'is\'"', 'display_form' => '\'is\'', 'dsl_form' => '\'is\'' }, '[Lex-25]' => { 'description' => 'Internal lexical symbol for "\'inaccessible\'"', 'display_form' => '\'inaccessible\'', 'dsl_form' => '\'inaccessible\'' }, '[Lex-26]' => { 'description' => 'Internal lexical symbol for "\'is\'"', 'display_form' => '\'is\'', 'dsl_form' => '\'is\'' }, '[Lex-27]' => { 'description' => 'Internal lexical symbol for "\'by\'"', 'display_form' => '\'by\'', 'dsl_form' => '\'by\'' }, '[Lex-28]' => { 'description' => 'Internal lexical symbol for "\'default\'"', 'display_form' => '\'default\'', 'dsl_form' => '\'default\'' }, '[Lex-29]' => { 'description' => 'Internal lexical symbol for "\'warn\'"', 'display_form' => '\'warn\'', 'dsl_form' => '\'warn\'' }, '[Lex-2]' => { 'description' => 'Internal lexical symbol for "\'}\'"', 'display_form' => '\'}\'', 'dsl_form' => '\'}\'' }, '[Lex-30]' => { 'description' => 'Internal lexical symbol for "\'ok\'"', 'display_form' => '\'ok\'', 'dsl_form' => '\'ok\'' }, '[Lex-31]' => { 'description' => 'Internal lexical symbol for "\'fatal\'"', 'display_form' => '\'fatal\'', 'dsl_form' => '\'fatal\'' }, '[Lex-32]' => { 'description' => 'Internal lexical symbol for "\',\'"', 'display_form' => '\',\'', 'dsl_form' => '\',\'' }, '[Lex-33]' => { 'description' => 'Internal lexical symbol for "\'action\'"', 'display_form' => '\'action\'', 'dsl_form' => '\'action\'' }, '[Lex-34]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-35]' => { 'description' => 'Internal lexical symbol for "\'assoc\'"', 'display_form' => '\'assoc\'', 'dsl_form' => '\'assoc\'' }, '[Lex-36]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-37]' => { 'description' => 'Internal lexical symbol for "\'left\'"', 'display_form' => '\'left\'', 'dsl_form' => '\'left\'' }, '[Lex-38]' => { 'description' => 'Internal lexical symbol for "\'assoc\'"', 'display_form' => '\'assoc\'', 'dsl_form' => '\'assoc\'' }, '[Lex-39]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-3]' => { 'description' => 'Internal lexical symbol for "\':start\'"', 'display_form' => '\':start\'', 'dsl_form' => '\':start\'' }, '[Lex-40]' => { 'description' => 'Internal lexical symbol for "\'right\'"', 'display_form' => '\'right\'', 'dsl_form' => '\'right\'' }, '[Lex-41]' => { 'description' => 'Internal lexical symbol for "\'assoc\'"', 'display_form' => '\'assoc\'', 'dsl_form' => '\'assoc\'' }, '[Lex-42]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-43]' => { 'description' => 'Internal lexical symbol for "\'group\'"', 'display_form' => '\'group\'', 'dsl_form' => '\'group\'' }, '[Lex-44]' => { 'description' => 'Internal lexical symbol for "\'separator\'"', 'display_form' => '\'separator\'', 'dsl_form' => '\'separator\'' }, '[Lex-45]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-46]' => { 'description' => 'Internal lexical symbol for "\'proper\'"', 'display_form' => '\'proper\'', 'dsl_form' => '\'proper\'' }, '[Lex-47]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-48]' => { 'description' => 'Internal lexical symbol for "\'rank\'"', 'display_form' => '\'rank\'', 'dsl_form' => '\'rank\'' }, '[Lex-49]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-4]' => { 'description' => 'Internal lexical symbol for "\'start\'"', 'display_form' => '\'start\'', 'dsl_form' => '\'start\'' }, '[Lex-50]' => { 'description' => 'Internal lexical symbol for "\'null-ranking\'"', 'display_form' => '\'null-ranking\'', 'dsl_form' => '\'null-ranking\'' }, '[Lex-51]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-52]' => { 'description' => 'Internal lexical symbol for "\'null\'"', 'display_form' => '\'null\'', 'dsl_form' => '\'null\'' }, '[Lex-53]' => { 'description' => 'Internal lexical symbol for "\'rank\'"', 'display_form' => '\'rank\'', 'dsl_form' => '\'rank\'' }, '[Lex-54]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-55]' => { 'description' => 'Internal lexical symbol for "\'low\'"', 'display_form' => '\'low\'', 'dsl_form' => '\'low\'' }, '[Lex-56]' => { 'description' => 'Internal lexical symbol for "\'high\'"', 'display_form' => '\'high\'', 'dsl_form' => '\'high\'' }, '[Lex-57]' => { 'description' => 'Internal lexical symbol for "\'priority\'"', 'display_form' => '\'priority\'', 'dsl_form' => '\'priority\'' }, '[Lex-58]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-59]' => { 'description' => 'Internal lexical symbol for "\'pause\'"', 'display_form' => '\'pause\'', 'dsl_form' => '\'pause\'' }, '[Lex-5]' => { 'description' => 'Internal lexical symbol for "\'symbol\'"', 'display_form' => '\'symbol\'', 'dsl_form' => '\'symbol\'' }, '[Lex-60]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-61]' => { 'description' => 'Internal lexical symbol for "\'event\'"', 'display_form' => '\'event\'', 'dsl_form' => '\'event\'' }, '[Lex-62]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-63]' => { 'description' => 'Internal lexical symbol for "\'forgiving\'"', 'display_form' => '\'forgiving\'', 'dsl_form' => '\'forgiving\'' }, '[Lex-64]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-65]' => { 'description' => 'Internal lexical symbol for "\'latm\'"', 'display_form' => '\'latm\'', 'dsl_form' => '\'latm\'' }, '[Lex-66]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-67]' => { 'description' => 'Internal lexical symbol for "\'bless\'"', 'display_form' => '\'bless\'', 'dsl_form' => '\'bless\'' }, '[Lex-68]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-69]' => { 'description' => 'Internal lexical symbol for "\'name\'"', 'display_form' => '\'name\'', 'dsl_form' => '\'name\'' }, '[Lex-6]' => { 'description' => 'Internal lexical symbol for "\'is\'"', 'display_form' => '\'is\'', 'dsl_form' => '\'is\'' }, '[Lex-70]' => { 'description' => 'Internal lexical symbol for "\'=>\'"', 'display_form' => '\'=>\'', 'dsl_form' => '\'=>\'' }, '[Lex-71]' => { 'description' => 'Internal lexical symbol for "\'(\'"', 'display_form' => '\'(\'', 'dsl_form' => '\'(\'' }, '[Lex-72]' => { 'description' => 'Internal lexical symbol for "\')\'"', 'display_form' => '\')\'', 'dsl_form' => '\')\'' }, '[Lex-73]' => { 'description' => 'Internal lexical symbol for "\'*\'"', 'display_form' => '\'*\'', 'dsl_form' => '\'*\'' }, '[Lex-74]' => { 'description' => 'Internal lexical symbol for "\'+\'"', 'display_form' => '\'+\'', 'dsl_form' => '\'+\'' }, '[Lex-7]' => { 'description' => 'Internal lexical symbol for "\':default\'"', 'display_form' => '\':default\'', 'dsl_form' => '\':default\'' }, '[Lex-8]' => { 'description' => 'Internal lexical symbol for "\'lexeme\'"', 'display_form' => '\'lexeme\'', 'dsl_form' => '\'lexeme\'' }, '[Lex-9]' => { 'description' => 'Internal lexical symbol for "\'default\'"', 'display_form' => '\'default\'', 'dsl_form' => '\'default\'' }, '[[\']]' => { 'description' => 'Character class: [\']', 'display_form' => '[\']', 'dsl_form' => '[\']' }, '[[+-]]' => { 'description' => 'Character class: [+-]', 'display_form' => '[+-]', 'dsl_form' => '[+-]' }, '[[,]]' => { 'description' => 'Character class: [,]', 'display_form' => '[,]', 'dsl_form' => '[,]' }, '[[01]]' => { 'description' => 'Character class: [01]', 'display_form' => '[01]', 'dsl_form' => '[01]' }, '[[[:alnum:]]]' => { 'description' => 'Character class: [[:alnum:]]', 'display_form' => '[[:alnum:]]', 'dsl_form' => '[[:alnum:]]' }, '[[\\#]]' => { 'description' => 'Character class: [\\#]', 'display_form' => '[\\#]', 'dsl_form' => '[\\#]' }, '[[\\(]]' => { 'description' => 'Character class: [\\(]', 'display_form' => '[\\(]', 'dsl_form' => '[\\(]' }, '[[\\)]]' => { 'description' => 'Character class: [\\)]', 'display_form' => '[\\)]', 'dsl_form' => '[\\)]' }, '[[\\*]]' => { 'description' => 'Character class: [\\*]', 'display_form' => '[\\*]', 'dsl_form' => '[\\*]' }, '[[\\+]]' => { 'description' => 'Character class: [\\+]', 'display_form' => '[\\+]', 'dsl_form' => '[\\+]' }, '[[\\,]]' => { 'description' => 'Character class: [\\,]', 'display_form' => '[\\,]', 'dsl_form' => '[\\,]' }, '[[\\-]]' => { 'description' => 'Character class: [\\-]', 'display_form' => '[\\-]', 'dsl_form' => '[\\-]' }, '[[\\:]]' => { 'description' => 'Character class: [\\:]', 'display_form' => '[\\:]', 'dsl_form' => '[\\:]' }, '[[\\;]]' => { 'description' => 'Character class: [\\;]', 'display_form' => '[\\;]', 'dsl_form' => '[\\;]' }, '[[\\<]]' => { 'description' => 'Character class: [\\<]', 'display_form' => '[\\<]', 'dsl_form' => '[\\<]' }, '[[\\=]]' => { 'description' => 'Character class: [\\=]', 'display_form' => '[\\=]', 'dsl_form' => '[\\=]' }, '[[\\>]]' => { 'description' => 'Character class: [\\>]', 'display_form' => '[\\>]', 'dsl_form' => '[\\>]' }, '[[\\[]]' => { 'description' => 'Character class: [\\[]', 'display_form' => '[\\[]', 'dsl_form' => '[\\[]' }, '[[\\\\]]' => { 'description' => 'Character class: [\\\\]', 'display_form' => '[\\\\]', 'dsl_form' => '[\\\\]' }, '[[\\]]]' => { 'description' => 'Character class: [\\]]', 'display_form' => '[\\]]', 'dsl_form' => '[\\]]' }, '[[\\^]]' => { 'description' => 'Character class: [\\^]', 'display_form' => '[\\^]', 'dsl_form' => '[\\^]' }, '[[\\d]]' => { 'description' => 'Character class: [\\d]', 'display_form' => '[\\d]', 'dsl_form' => '[\\d]' }, '[[\\s\\w]]' => { 'description' => 'Character class: [\\s\\w]', 'display_form' => '[\\s\\w]', 'dsl_form' => '[\\s\\w]' }, '[[\\s]]' => { 'description' => 'Character class: [\\s]', 'display_form' => '[\\s]', 'dsl_form' => '[\\s]' }, '[[\\w]]' => { 'description' => 'Character class: [\\w]', 'display_form' => '[\\w]', 'dsl_form' => '[\\w]' }, '[[\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]]' => { 'description' => 'Character class: [\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]', 'display_form' => '[\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]', 'dsl_form' => '[\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]' }, '[[\\{]]' => { 'description' => 'Character class: [\\{]', 'display_form' => '[\\{]', 'dsl_form' => '[\\{]' }, '[[\\|]]' => { 'description' => 'Character class: [\\|]', 'display_form' => '[\\|]', 'dsl_form' => '[\\|]' }, '[[\\}]]' => { 'description' => 'Character class: [\\}]', 'display_form' => '[\\}]', 'dsl_form' => '[\\}]' }, '[[\\~]]' => { 'description' => 'Character class: [\\~]', 'display_form' => '[\\~]', 'dsl_form' => '[\\~]' }, '[[^\'\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]]' => { 'description' => 'Character class: [^\'\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]', 'display_form' => '[^\'\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]', 'dsl_form' => '[^\'\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]' }, '[[^\\x{5d}\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]]' => { 'description' => 'Character class: [^\\x{5d}\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]', 'display_form' => '[^\\x{5d}\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]', 'dsl_form' => '[^\\x{5d}\\x{0A}\\x{0B}\\x{0C}\\x{0D}\\x{0085}\\x{2028}\\x{2029}]' }, '[[^\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]]' => { 'description' => 'Character class: [^\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]', 'display_form' => '[^\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]', 'dsl_form' => '[^\\x{A}\\x{B}\\x{C}\\x{D}\\x{2028}\\x{2029}]' }, '[[a-zA-Z]]' => { 'description' => 'Character class: [a-zA-Z]', 'display_form' => '[a-zA-Z]', 'dsl_form' => '[a-zA-Z]' }, '[[a]]' => { 'description' => 'Character class: [a]', 'display_form' => '[a]', 'dsl_form' => '[a]' }, '[[b]]' => { 'description' => 'Character class: [b]', 'display_form' => '[b]', 'dsl_form' => '[b]' }, '[[c]]' => { 'description' => 'Character class: [c]', 'display_form' => '[c]', 'dsl_form' => '[c]' }, '[[d]]' => { 'description' => 'Character class: [d]', 'display_form' => '[d]', 'dsl_form' => '[d]' }, '[[e]]' => { 'description' => 'Character class: [e]', 'display_form' => '[e]', 'dsl_form' => '[e]' }, '[[f]]' => { 'description' => 'Character class: [f]', 'display_form' => '[f]', 'dsl_form' => '[f]' }, '[[g]]' => { 'description' => 'Character class: [g]', 'display_form' => '[g]', 'dsl_form' => '[g]' }, '[[h]]' => { 'description' => 'Character class: [h]', 'display_form' => '[h]', 'dsl_form' => '[h]' }, '[[i]]' => { 'description' => 'Character class: [i]', 'display_form' => '[i]', 'dsl_form' => '[i]' }, '[[k]]' => { 'description' => 'Character class: [k]', 'display_form' => '[k]', 'dsl_form' => '[k]' }, '[[l]]' => { 'description' => 'Character class: [l]', 'display_form' => '[l]', 'dsl_form' => '[l]' }, '[[m]]' => { 'description' => 'Character class: [m]', 'display_form' => '[m]', 'dsl_form' => '[m]' }, '[[n]]' => { 'description' => 'Character class: [n]', 'display_form' => '[n]', 'dsl_form' => '[n]' }, '[[o]]' => { 'description' => 'Character class: [o]', 'display_form' => '[o]', 'dsl_form' => '[o]' }, '[[p]]' => { 'description' => 'Character class: [p]', 'display_form' => '[p]', 'dsl_form' => '[p]' }, '[[r]]' => { 'description' => 'Character class: [r]', 'display_form' => '[r]', 'dsl_form' => '[r]' }, '[[s]]' => { 'description' => 'Character class: [s]', 'display_form' => '[s]', 'dsl_form' => '[s]' }, '[[t]]' => { 'description' => 'Character class: [t]', 'display_form' => '[t]', 'dsl_form' => '[t]' }, '[[u]]' => { 'description' => 'Character class: [u]', 'display_form' => '[u]', 'dsl_form' => '[u]' }, '[[v]]' => { 'description' => 'Character class: [v]', 'display_form' => '[v]', 'dsl_form' => '[v]' }, '[[w]]' => { 'description' => 'Character class: [w]', 'display_form' => '[w]', 'dsl_form' => '[w]' }, '[[x]]' => { 'description' => 'Character class: [x]', 'display_form' => '[x]', 'dsl_form' => '[x]' }, '[[y]]' => { 'description' => 'Character class: [y]', 'display_form' => '[y]', 'dsl_form' => '[y]' } } } }; ## The code before this line was automatically generated by sl_to_hash.pl ##use critic return $hashed_metag; } ## end sub meta_grammar 1; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/SLR.pm0000444000000000000000000021030712342464706016132 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::Scanless::R; use 5.010; use strict; use warnings; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic(BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic package Marpa::R2::Internal::Scanless::R; use Scalar::Util 'blessed'; use English qw( -no_match_vars ); our $PACKAGE = 'Marpa::R2::Scanless::R'; our $TRACE_FILE_HANDLE; sub Marpa::R2::Scanless::R::last_completed_range { my ( $self, $symbol_name ) = @_; my ( $start, $length ) = $self->last_completed($symbol_name); return if not defined $start; my $end = $start + $length; return ( $start, $end ); } ## end sub Marpa::R2::Scanless::R::last_completed_range # Given a scanless # recognizer and a symbol, # return the start earley set # and length # of the last such symbol completed, # undef if there was none. sub Marpa::R2::Scanless::R::last_completed { my ( $slr, $symbol_name ) = @_; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thick_g1_grammar = $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thin_g1_recce = $thick_g1_recce->thin(); my $sought_rules = $slg->[Marpa::R2::Internal::Scanless::G::CACHE_RULEIDS_BY_LHS_NAME] ->{$symbol_name}; if ( not defined $sought_rules ) { my $g1_tracer = $thick_g1_grammar->tracer(); my $thin_g1_grammar = $thick_g1_grammar->thin(); my $symbol_id = $g1_tracer->symbol_by_name($symbol_name); Marpa::R2::exception("Bad symbol in last_completed(): $symbol_name") if not defined $symbol_id; $sought_rules = $slg->[Marpa::R2::Internal::Scanless::G::CACHE_RULEIDS_BY_LHS_NAME] ->{$symbol_name} = [ grep { $thin_g1_grammar->rule_lhs($_) == $symbol_id; } 0 .. $thin_g1_grammar->highest_rule_id() ]; Marpa::R2::exception( "Looking for completion of non-existent rule lhs: $symbol_name") if not scalar @{$sought_rules}; } ## end if ( not defined $sought_rules ) my $latest_earley_set = $thin_g1_recce->latest_earley_set(); my $earley_set = $latest_earley_set; # Initialize to one past the end, so we can tell if there were no hits my $first_origin = $latest_earley_set + 1; EARLEY_SET: while ( $earley_set >= 0 ) { $thin_g1_recce->progress_report_start($earley_set); ITEM: while (1) { my ( $rule_id, $dot_position, $origin ) = $thin_g1_recce->progress_item(); last ITEM if not defined $rule_id; next ITEM if $dot_position != -1; next ITEM if not scalar grep { $_ == $rule_id } @{$sought_rules}; next ITEM if $origin >= $first_origin; $first_origin = $origin; } ## end ITEM: while (1) $thin_g1_recce->progress_report_finish(); last EARLEY_SET if $first_origin <= $latest_earley_set; $earley_set--; } ## end EARLEY_SET: while ( $earley_set >= 0 ) return if $earley_set < 0; return ( $first_origin, ( $earley_set - $first_origin ) ); } ## end sub Marpa::R2::Scanless::R::last_completed # In terms of earley sets. # Kept for backward compatibiity sub Marpa::R2::Scanless::R::range_to_string { my ( $self, $start_earley_set, $end_earley_set ) = @_; return $self->substring( $start_earley_set, $end_earley_set - $start_earley_set ); } # Not documented. Should I? sub Marpa::R2::Scanless::R::es_to_input_span { my ( $slr, $start_earley_set, $length_in_parse_locations ) = @_; return if not defined $start_earley_set or not defined $length_in_parse_locations; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thin_g1_recce = $thick_g1_recce->thin(); my $latest_earley_set = $thin_g1_recce->latest_earley_set(); my $earley_set_for_first_position = $start_earley_set + 1; my $earley_set_for_last_position = $start_earley_set + $length_in_parse_locations; die 'Error in $slr->substring(', "$start_earley_set, $length_in_parse_locations", '): ', "start ($start_earley_set) is at or after latest_earley_set ($latest_earley_set)" if $earley_set_for_first_position > $latest_earley_set; die 'Error in $slr->substring(', "$start_earley_set, $length_in_parse_locations", '): ', "end ( $start_earley_set + $length_in_parse_locations ) is after latest_earley_set ($latest_earley_set)" if $earley_set_for_last_position > $latest_earley_set; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my ($first_start_position) = $thin_slr->span($earley_set_for_first_position); my ( $last_start_position, $last_length ) = $thin_slr->span($earley_set_for_last_position); my $length_in_characters = ( $last_start_position + $last_length ) - $first_start_position; # Negative lengths are quite possible if the application has jumped around in # the input. $length_in_characters = 0 if $length_in_characters <= 0; return ( $first_start_position, $length_in_characters ); } ## end sub Marpa::R2::Scanless::R::es_to_input_span # Substring in terms of earley sets. # Necessary for the use of show_progress() # Given a scanless recognizer and # and two earley sets, return the input string sub Marpa::R2::Scanless::R::substring { my ( $slr, $start_earley_set, $length_in_parse_locations ) = @_; my ( $first_start_position, $length_in_characters ) = $slr->es_to_input_span( $start_earley_set, $length_in_parse_locations ); my $p_input = $slr->[Marpa::R2::Internal::Scanless::R::P_INPUT_STRING]; return substr ${$p_input}, $first_start_position, $length_in_characters; } ## end sub Marpa::R2::Scanless::R::substring sub Marpa::R2::Scanless::R::g1_location_to_span { my ( $self, $g1_location ) = @_; my $thin_self = $self->[Marpa::R2::Internal::Scanless::R::C]; return $thin_self->span($g1_location); } # Substring in terms of locations in the input stream # This is the one users will be most interested in. sub Marpa::R2::Scanless::R::literal { my ( $slr, $start_pos, $length ) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; return $thin_slr->substring( $start_pos, $length ); } ## end sub Marpa::R2::Scanless::R::literal sub Marpa::R2::Internal::Scanless::meta_recce { my ($hash_args) = @_; state $meta_grammar = Marpa::R2::Internal::Scanless::meta_grammar(); $hash_args->{grammar} = $meta_grammar; my $self = Marpa::R2::Scanless::R->new($hash_args); return $self; } ## end sub Marpa::R2::Internal::Scanless::meta_recce # For error messages, make it convenient to use an SLR sub Marpa::R2::Scanless::R::rule_show { my ( $slr, $rule_id ) = @_; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; return $slg->rule_show($rule_id); } sub Marpa::R2::Scanless::R::new { my ( $class, @args ) = @_; my $self = []; bless $self, $class; my $g1_recce_args = Marpa::R2::Internal::Scanless::R::set( $self, "new", @args ); my $too_many_earley_items = $g1_recce_args->{too_many_earley_items}; my $slg = $self->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thick_g1_grammar = $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR]; $g1_recce_args->{grammar} = $thick_g1_grammar; my $thick_g1_recce = $self->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE] = Marpa::R2::Recognizer->new($g1_recce_args); my $thin_self = Marpa::R2::Thin::SLR->new( $slg->[Marpa::R2::Internal::Scanless::G::C], $thick_g1_recce->thin() ); $thin_self->earley_item_warning_threshold_set($too_many_earley_items) if defined $too_many_earley_items; $self->[Marpa::R2::Internal::Scanless::R::C] = $thin_self; $self->[Marpa::R2::Internal::Scanless::R::EVENTS] = []; Marpa::R2::Internal::Scanless::convert_libmarpa_events($self); return $self; } ## end sub Marpa::R2::Scanless::R::new sub Marpa::R2::Scanless::R::set { my ( $slr, @args ) = @_; my $naif_recce_args = Marpa::R2::Internal::Scanless::R::set( $slr, "set", @args ); my $naif_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; $naif_recce->set($naif_recce_args); return $slr; } ## end sub Marpa::R2::Scanless::R::set # The context flag indicates whether this set is called directly by the user # or is for series reset or the constructor. "Context" flags of this kind # are much decried practice, and for good reason, but in this case # I think it is justified. # This logic really needs to be all in one place, and so a flag # to trigger the minor differences needed by the various calling # contexts is a small price to pay. sub Marpa::R2::Internal::Scanless::R::set { my ( $slr, $method, @hash_ref_args ) = @_; # These NAIF recce args are allowed in all contexts state $common_naif_recce_args = { map { ( $_, 1 ); } qw(end max_parses semantics_package too_many_earley_items trace_actions trace_file_handle trace_terminals trace_values) }; state $set_method_args = { map { ( $_, 1 ); } qw(trace_lexers), keys %{$common_naif_recce_args} }; state $new_method_args = { map { ( $_, 1 ); } qw(grammar ranking_method trace_lexers ), keys %{$set_method_args} }; state $series_restart_method_args = { map { ( $_, 1 ); } qw(trace_lexers), keys %{$common_naif_recce_args} }; for my $args (@hash_ref_args) { my $ref_type = ref $args; if ( not $ref_type ) { Marpa::R2::exception( q{$slr->} . $method . qq{() expects args as ref to HASH; got non-reference instead} ); } ## end if ( not $ref_type ) if ( $ref_type ne 'HASH' ) { Marpa::R2::exception( q{$slr->} . $method . qq{() expects args as ref to HASH, got ref to $ref_type instead} ); } ## end if ( $ref_type ne 'HASH' ) } ## end for my $args (@hash_ref_args) my %flat_args = (); for my $hash_ref (@hash_ref_args) { ARG: for my $arg_name ( keys %{$hash_ref} ) { $flat_args{$arg_name} = $hash_ref->{$arg_name}; } } my $ok_args = $set_method_args; $ok_args = $new_method_args if $method eq 'new'; $ok_args = $series_restart_method_args if $method eq 'series_restart'; my @bad_args = grep { not $ok_args->{$_} } keys %flat_args; if ( scalar @bad_args ) { Marpa::R2::exception( q{Bad named argument(s) to $slr->} . $method . q{() method: } . join q{ }, @bad_args ); } ## end if ( scalar @bad_args ) if ( $method eq 'new' ) { state $arg_name = 'grammar'; state $slg_class = 'Marpa::R2::Scanless::G'; my $slg = $flat_args{$arg_name}; Marpa::R2::exception( qq{Marpa::R2::Scanless::R::new() called without a "$arg_name" argument} ) if not defined $slg; if ( not blessed $slg or not $slg->isa($slg_class) ) { my $ref_type = ref $slg; my $desc = $ref_type ? "a ref to $ref_type" : 'not a ref'; Marpa::R2::exception( qq{'$arg_name' name argument to scanless_r->new() is $desc\n}, " It should be a ref to $slg_class\n" ); } ## end if ( not blessed $slg or not $slg->isa($slg_class) ) $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR] = $slg; } ## end if ( $method eq 'new' ) # A bit hack-ish, but some named args are copies straight to an member of # the Scanless::R class, so this maps named args to the index of the array # that holds the members. state $copy_arg_to_index = { trace_file_handle => Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE, trace_lexers => Marpa::R2::Internal::Scanless::R::TRACE_LEXERS, trace_terminals => Marpa::R2::Internal::Scanless::R::TRACE_TERMINALS, }; ARG: for my $arg_name ( keys %flat_args ) { my $index = $copy_arg_to_index->{$arg_name}; next ARG if not defined $index; my $value = $flat_args{$arg_name}; $slr->[$index] = $value; } ## end ARG: for my $arg_name ( keys %flat_args ) # Trace file handle can never be undefined if (not defined $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE] ) { my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE] = $slg->[Marpa::R2::Internal::Scanless::G::TRACE_FILE_HANDLE]; } ## end if ( not defined $slr->[...]) # These NAIF recce args, when applicable, are simply copies of the the # SLIF args of the same name state $copyable_naif_recce_args = { map { ( $_, 1 ); } qw(end max_parses semantics_package too_many_earley_items ranking_method trace_actions trace_file_handle trace_terminals trace_values) }; # Prune flat args of all those named args which are NOT to be copied # into the NAIF recce args for my $arg_name ( keys %flat_args ) { delete $flat_args{$arg_name} if not $copyable_naif_recce_args->{$arg_name}; } # In the new method, these items must always be set in the NAIF recce args if ( $method eq 'new' ) { $flat_args{trace_file_handle} //= $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; } return \%flat_args; } ## end sub Marpa::R2::Internal::Scanless::R::set sub Marpa::R2::Scanless::R::thin { return $_[0]->[Marpa::R2::Internal::Scanless::R::C]; } sub Marpa::R2::Scanless::R::trace { my ( $self, $level ) = @_; my $thin_slr = $self->[Marpa::R2::Internal::Scanless::R::C]; $level //= 1; return $thin_slr->trace($level); } ## end sub Marpa::R2::Scanless::R::trace sub Marpa::R2::Scanless::R::error { my ($self) = @_; return $self->[Marpa::R2::Internal::Scanless::R::READ_STRING_ERROR]; } sub Marpa::R2::Scanless::R::read { my ( $self, $p_string, $start_pos, $length ) = @_; $start_pos //= 0; $length //= -1; Marpa::R2::exception( "Multiple read()'s tried on a scannerless recognizer\n", ' Currently the string cannot be changed once set' ) if defined $self->[Marpa::R2::Internal::Scanless::R::P_INPUT_STRING]; if ( ( my $ref_type = ref $p_string ) ne 'SCALAR' ) { my $desc = $ref_type ? "a ref to $ref_type" : 'not a ref'; Marpa::R2::exception( qq{Arg to Marpa::R2::Scanless::R::read() is $desc\n}, ' It should be a ref to scalar' ); } ## end if ( ( my $ref_type = ref $p_string ) ne 'SCALAR' ) if ( not defined ${$p_string} ) { Marpa::R2::exception( qq{Arg to Marpa::R2::Scanless::R::read() is a ref to an undef\n}, ' It should be a ref to a defined scalar' ); } ## end if ( ( my $ref_type = ref $p_string ) ne 'SCALAR' ) $self->[Marpa::R2::Internal::Scanless::R::P_INPUT_STRING] = $p_string; my $thin_slr = $self->[Marpa::R2::Internal::Scanless::R::C]; my $trace_terminals = $self->[Marpa::R2::Internal::Scanless::R::TRACE_TERMINALS] // 0; my $trace_lexers = $self->[Marpa::R2::Internal::Scanless::R::TRACE_LEXERS] // 0; $thin_slr->trace_terminals($trace_terminals) if $trace_terminals; $thin_slr->trace_lexers($trace_lexers) if $trace_lexers; $thin_slr->string_set($p_string); return 0 if @{ $self->[Marpa::R2::Internal::Scanless::R::EVENTS] }; return $self->resume( $start_pos, $length ); } ## end sub Marpa::R2::Scanless::R::read sub Marpa::R2::Scanless::R::lexer_set { my ( $slr, $lexer_name ) = @_; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_id = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_BY_NAME]->{$lexer_name}; Marpa::R2::exception( "Attempt to switch to unknown lexer: $lexer_name" ) if not defined $lexer_id; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; return $thin_slr->lexer_set($lexer_id); } my $libmarpa_trace_event_handlers = { 'g1 accepted lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $lexeme_start_pos, $lexeme_end_pos, $g1_lexeme, $lexer_id ) = @{$event}; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $raw_token_value = $thin_slr->substring( $lexeme_start_pos, $lexeme_end_pos - $lexeme_start_pos ); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; say {$trace_file_handle} qq{Lexer "$lexer_name" accepted lexeme }, input_range_describe( $slr, $lexeme_start_pos, $lexeme_end_pos - 1 ), q{: }, $thick_g1_grammar->symbol_in_display_form($g1_lexeme), qq{; value="$raw_token_value"} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'rejected lexeme' => sub { my ( $slr, $event ) = @_; # Necessary to check, because this one can be returned when not tracing return if not $slr->[Marpa::R2::Internal::Scanless::R::TRACE_TERMINALS]; my ( undef, undef, $lexeme_start_pos, $lexeme_end_pos, $g1_lexeme, $lexer_id ) = @{$event}; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $raw_token_value = $thin_slr->substring( $lexeme_start_pos, $lexeme_end_pos - $lexeme_start_pos ); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; say {$trace_file_handle} qq{Lexer "$lexer_name" rejected lexeme }, input_range_describe( $slr, $lexeme_start_pos, $lexeme_end_pos - 1 ), q{: }, $thick_g1_grammar->symbol_in_display_form($g1_lexeme), qq{; value="$raw_token_value"} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'expected lexeme' => sub { my ( $slr, $event ) = @_; # Necessary to check, because this one can be returned when not tracing return if not $slr->[Marpa::R2::Internal::Scanless::R::TRACE_TERMINALS]; my ( undef, undef, $position, $g1_lexeme, $assertion_id, $lexer_id ) = @{$event}; my ( $line, $column ) = $slr->line_column($position); my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; say {$trace_file_handle} qq{Lexer "$lexer_name" expected lexeme }, $thick_g1_grammar->symbol_in_display_form($g1_lexeme), " at line $line, column $column; assertion ID = $assertion_id" or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'outprioritized lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $lexeme_start_pos, $lexeme_end_pos, $g1_lexeme, $lexer_id, $lexeme_priority, $required_priority ) = @{$event}; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $raw_token_value = $thin_slr->substring( $lexeme_start_pos, $lexeme_end_pos - $lexeme_start_pos ); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; say {$trace_file_handle} qq{Lexer "$lexer_name" outprioritized lexeme }, input_range_describe( $slr, $lexeme_start_pos, $lexeme_end_pos - 1 ), q{: }, $thick_g1_grammar->symbol_in_display_form($g1_lexeme), qq{; value="$raw_token_value"; }, qq{priority was $lexeme_priority, but $required_priority was required} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'g1 duplicate lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $lexeme_start_pos, $lexeme_end_pos, $g1_lexeme ) = @{$event}; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $raw_token_value = $thin_slr->substring( $lexeme_start_pos, $lexeme_end_pos - $lexeme_start_pos ); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); say {$trace_file_handle} 'Rejected as duplicate lexeme ', input_range_describe( $slr, $lexeme_start_pos, $lexeme_end_pos - 1 ), q{: }, $thick_g1_grammar->symbol_in_display_form($g1_lexeme), qq{; value="$raw_token_value"} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'g1 attempting lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $lexeme_start_pos, $lexeme_end_pos, $g1_lexeme ) = @{$event}; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $raw_token_value = $thin_slr->substring( $lexeme_start_pos, $lexeme_end_pos - $lexeme_start_pos ); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); say {$trace_file_handle} 'Attempting to read lexeme ', input_range_describe( $slr, $lexeme_start_pos, $lexeme_end_pos - 1 ), q{: }, $thick_g1_grammar->symbol_in_display_form($g1_lexeme), qq{; value="$raw_token_value"} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'lexer reading codepoint' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $codepoint, $position, $lexer_id ) = @{$event}; my $char = chr $codepoint; my @char_desc = (); push @char_desc, qq{"$char"} if $char =~ /[\p{IsGraph}]/xms; push @char_desc, ( sprintf '0x%04x', $codepoint ); my $char_desc = join q{ }, @char_desc; my ( $line, $column ) = $slr->line_column($position); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; say {$trace_file_handle} qq{Lexer "$lexer_name" reading codepoint $char_desc at line $line, column $column} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'lexer accepted codepoint' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $codepoint, $position, $token_id, $lexer_id ) = @{$event}; my $char = chr $codepoint; my @char_desc = (); push @char_desc, qq{"$char"} if $char =~ /[\p{IsGraph}]/xms; push @char_desc, ( sprintf '0x%04x', $codepoint ); my $char_desc = join q{ }, @char_desc; my $grammar = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thick_lex_grammar = $grammar->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS] ->[$lexer_id]; my $symbol_in_display_form = $thick_lex_grammar->symbol_in_display_form($token_id), my ( $line, $column ) = $slr->line_column($position); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; say {$trace_file_handle} qq{Lexer "$lexer_name" codepoint $char_desc accepted as $symbol_in_display_form at line $line, column $column} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'lexer rejected codepoint' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $codepoint, $position, $token_id, $lexer_id ) = @{$event}; my $char = chr $codepoint; my @char_desc = (); push @char_desc, qq{"$char"} if $char =~ /[\p{IsGraph}]/xms; push @char_desc, ( sprintf '0x%04x', $codepoint ); my $char_desc = join q{ }, @char_desc; my $grammar = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thick_lex_grammar = $grammar->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS] ->[$lexer_id]; my $symbol_in_display_form = $thick_lex_grammar->symbol_in_display_form($token_id), my ( $line, $column ) = $slr->line_column($position); my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; say {$trace_file_handle} qq{Lexer "$lexer_name" codepoint $char_desc rejected as $symbol_in_display_form at line $line, column $column} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'lexer restarted recognizer' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $position, $lexer_id ) = @{$event}; my ( $line, $column ) = $slr->line_column($position); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; say {$trace_file_handle} qq{Lexer "$lexer_name" restarted recognizer at line $line, column $column} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'changing lexers' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $position, $old_lexer_id, $new_lexer_id ) = @{$event}; my ( $line, $column ) = $slr->line_column($position); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $old_lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$old_lexer_id]; my $new_lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$new_lexer_id]; say {$trace_file_handle} qq{Changing lexers from "$old_lexer_name" to "$new_lexer_name" at line $line, column $column} or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'discarded lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $lex_rule_id, $start, $end, $lexer_id ) = @{$event}; my $grammar = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thick_lex_grammar = $grammar->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS] ->[$lexer_id]; my $grammar_c = $thick_lex_grammar->[Marpa::R2::Internal::Grammar::C]; my $rule_length = $grammar_c->rule_length($lex_rule_id); my @rhs_ids = map { $grammar_c->rule_rhs( $lex_rule_id, $_ ) } ( 0 .. $rule_length - 1 ); my @rhs = map { $thick_lex_grammar->symbol_in_display_form($_) } @rhs_ids; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; say {$trace_file_handle} qq{Lexer "$lexer_name" discarded lexeme }, input_range_describe( $slr, $start, $end - 1 ), q{: }, join q{ }, @rhs or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'g1 pausing before lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $start, $end, $lexeme_id ) = @{$event}; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); my $lexeme_name = $thick_g1_grammar->symbol_in_display_form($lexeme_id); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; say {$trace_file_handle} 'Paused before lexeme ', input_range_describe( $slr, $start, $end - 1 ), ": $lexeme_name" or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'g1 pausing after lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $start, $end, $lexeme_id ) = @{$event}; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); my $lexeme_name = $thick_g1_grammar->symbol_in_display_form($lexeme_id); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; say {$trace_file_handle} 'Paused after lexeme ', input_range_describe( $slr, $start, $end - 1 ), ": $lexeme_name" or Marpa::R2::exception("Could not say(): $ERRNO"); }, 'ignored lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, undef, $g1_symbol_id, $start, $end ) = @{$event}; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); my $lexeme_name = $thick_g1_grammar->symbol_in_display_form($g1_symbol_id); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; say {$trace_file_handle} 'Ignored lexeme ', input_range_describe( $slr, $start, $end - 1 ), ": $lexeme_name" or Marpa::R2::exception("Could not say(): $ERRNO"); }, }; my $libmarpa_event_handlers = { q{'trace} => sub { my ( $slr, $event ) = @_; my $handler = $libmarpa_trace_event_handlers->{ $event->[1] }; if ( defined $handler ) { $handler->( $slr, $event ); } else { my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; say {$trace_file_handle} 'Trace event: ', join q{ }, @{$event} or Marpa::R2::exception("Could not say(): $ERRNO"); } ## end else [ if ( defined $handler ) ] return 0; }, 'symbol completed' => sub { my ( $slr, $event ) = @_; my ( undef, $completed_symbol_id ) = @{$event}; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $completion_event_by_id = $slg->[Marpa::R2::Internal::Scanless::G::COMPLETION_EVENT_BY_ID]; push @{ $slr->[Marpa::R2::Internal::Scanless::R::EVENTS] }, [ $completion_event_by_id->[$completed_symbol_id] ]; return 1; }, 'symbol nulled' => sub { my ( $slr, $event ) = @_; my ( undef, $nulled_symbol_id ) = @{$event}; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $nulled_event_by_id = $slg->[Marpa::R2::Internal::Scanless::G::NULLED_EVENT_BY_ID]; push @{ $slr->[Marpa::R2::Internal::Scanless::R::EVENTS] }, [ $nulled_event_by_id->[$nulled_symbol_id] ]; return 1; }, 'symbol predicted' => sub { my ( $slr, $event ) = @_; my ( undef, $predicted_symbol_id ) = @{$event}; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $prediction_event_by_id = $slg->[Marpa::R2::Internal::Scanless::G::PREDICTION_EVENT_BY_ID]; push @{ $slr->[Marpa::R2::Internal::Scanless::R::EVENTS] }, [ $prediction_event_by_id->[$predicted_symbol_id] ]; return 1; }, # 'after lexeme' is same -- copied over below 'before lexeme' => sub { my ( $slr, $event ) = @_; my ( undef, $lexeme_id ) = @{$event}; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexeme_event = $slg->[Marpa::R2::Internal::Scanless::G::LEXEME_EVENT_BY_ID] ->[$lexeme_id]; push @{ $slr->[Marpa::R2::Internal::Scanless::R::EVENTS] }, [$lexeme_event] if defined $lexeme_event; return 1; }, 'unknown g1 event' => sub { my ( $slr, $event ) = @_; Marpa::R2::exception( ( join q{ }, 'Unknown event:', @{$event} ) ); return 0; }, 'no acceptable input' => sub { ## Do nothing at this point return 0; }, }; $libmarpa_event_handlers->{'after lexeme'} = $libmarpa_event_handlers->{'before lexeme'}; # Return 1 if internal scanning should pause sub Marpa::R2::Internal::Scanless::convert_libmarpa_events { my ($slr) = @_; my $pause = 0; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; EVENT: for my $event ( $thin_slr->events() ) { my ($event_type) = @{$event}; my $handler = $libmarpa_event_handlers->{$event_type}; Marpa::R2::exception( ( join q{ }, 'Unknown event:', @{$event} ) ) if not defined $handler; $pause = 1 if $handler->( $slr, $event ); } ## end EVENT: for my $event ( $thin_slr->events() ) return $pause; } ## end sub Marpa::R2::Internal::Scanless::convert_libmarpa_events sub Marpa::R2::Scanless::R::resume { my ( $slr, $start_pos, $length ) = @_; Marpa::R2::exception( "Attempt to resume an SLIF recce which has no string set\n", ' The string should be set first using read()' ) if not defined $slr->[Marpa::R2::Internal::Scanless::R::P_INPUT_STRING]; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $trace_terminals = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_TERMINALS] // 0; my $trace_lexers = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_LEXERS] // 0; $thin_slr->pos_set( $start_pos, $length ); $slr->[Marpa::R2::Internal::Scanless::R::EVENTS] = []; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thin_slg = $slg->[Marpa::R2::Internal::Scanless::G::C]; OUTER_READ: while (1) { my $problem_code = $thin_slr->read(); last OUTER_READ if not $problem_code; my $pause = Marpa::R2::Internal::Scanless::convert_libmarpa_events($slr); if ( $trace_lexers > 2 ) { my $stream_pos = $thin_slr->pos(); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $lexer_id = $thin_slr->current_lexer(); my $thick_lex_grammar = $slg->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS]->[$lexer_id]; my $lex_tracer = $thick_lex_grammar->tracer(); my ( $line, $column ) = $slr->line_column($stream_pos); print {$trace_file_handle} qq{\n=== Progress report at line $line, column $column\n}, $lex_tracer->lexer_progress_report($slr), qq{=== End of progress report at line $line, column $column\n}, or Marpa::R2::exception("Cannot print(): $ERRNO"); } ## end if ( $trace_lexers > 2 ) last OUTER_READ if $pause; next OUTER_READ if $problem_code eq 'event'; next OUTER_READ if $problem_code eq 'trace'; if ( $problem_code eq 'invalid char' ) { my $codepoint = $thin_slr->codepoint(); my $lexer_id = $thin_slr->current_lexer(); my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; Marpa::R2::exception( qq{Lexer "$lexer_name" failed at unacceptable character }, character_describe( chr $codepoint ) ); } ## end if ( $problem_code eq 'invalid char' ) if ( $problem_code eq 'unregistered char' ) { state $op_alternative = Marpa::R2::Thin::op('alternative'); state $op_invalid_char = Marpa::R2::Thin::op('invalid_char'); state $op_earleme_complete = Marpa::R2::Thin::op('earleme_complete'); # Recover by registering character, if we can my $codepoint = $thin_slr->codepoint(); my $character = chr($codepoint); my $lexer_id = $thin_slr->current_lexer(); my $character_class_table = $slg->[Marpa::R2::Internal::Scanless::G::CHARACTER_CLASS_TABLES] ->[$lexer_id]; my @ops; for my $entry ( @{$character_class_table} ) { my ( $symbol_id, $re ) = @{$entry}; if ( $character =~ $re ) { if ( $trace_terminals >= 2 ) { my $thick_lex_grammar = $slg->[ Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS] ->[$lexer_id]; my $trace_file_handle = $slr->[ Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $char_desc = sprintf 'U+%04x', $codepoint; if ( $character =~ m/[[:graph:]]+/ ) { $char_desc .= qq{ '$character'}; } my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; say {$trace_file_handle} qq{Lexer "$lexer_name" registering character $char_desc as symbol $symbol_id: }, $thick_lex_grammar->symbol_in_display_form( $symbol_id) or Marpa::R2::exception("Could not say(): $ERRNO"); } ## end if ( $trace_terminals >= 2 ) push @ops, $op_alternative, $symbol_id, 1, 1; } ## end if ( $character =~ $re ) } ## end for my $entry ( @{$character_class_table} ) if ( not @ops ) { $thin_slr->char_register( $codepoint, $op_invalid_char ); next OUTER_READ; } $thin_slr->char_register( $codepoint, @ops, $op_earleme_complete ); next OUTER_READ; } ## end if ( $problem_code eq 'unregistered char' ) return $slr->read_problem($problem_code); } ## end OUTER_READ: while (1) return $thin_slr->pos(); } ## end sub Marpa::R2::Scanless::R::resume sub Marpa::R2::Scanless::R::event { my ( $self, $event_ix ) = @_; return $self->[Marpa::R2::Internal::Scanless::R::EVENTS]->[$event_ix]; } sub Marpa::R2::Scanless::R::events { my ($self) = @_; return $self->[Marpa::R2::Internal::Scanless::R::EVENTS]; } ## From here, recovery is a matter for the caller, ## if it is possible at all sub Marpa::R2::Scanless::R::read_problem { my ( $slr, $problem_code ) = @_; die 'No problem_code in slr->read_problem()' if not $problem_code; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $grammar = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_id = $thin_slr->current_lexer(); my $thick_lex_grammar = $grammar->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS]->[$lexer_id]; my $lex_tracer = $thick_lex_grammar->tracer(); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thin_g1_recce = $thick_g1_recce->thin(); my $thick_g1_grammar = $thick_g1_recce->grammar(); my $g1_tracer = $thick_g1_grammar->tracer(); my $pos = $thin_slr->pos(); my $problem_pos = $pos; my $p_string = $slr->[Marpa::R2::Internal::Scanless::R::P_INPUT_STRING]; my $length_of_string = length ${$p_string}; my $problem; my $stream_status = 0; my $g1_status = 0; CODE_TO_PROBLEM: { if ( $problem_code eq 'R1 exhausted before end' ) { my ($lexeme_start) = $thin_slr->lexeme_span(); my ( $line, $column ) = $slr->line_column($lexeme_start); $problem = "Parse exhausted, but lexemes remain, at line $line, column $column\n"; last CODE_TO_PROBLEM; } if ( $problem_code eq 'SLIF loop' ) { my ($lexeme_start) = $thin_slr->lexeme_span(); my ( $line, $column ) = $slr->line_column($lexeme_start); $problem = "SLIF loops at line $line, column $column"; last CODE_TO_PROBLEM; } if ( $problem_code eq 'no lexeme' ) { $problem_pos = $thin_slr->problem_pos(); my ( $line, $column ) = $slr->line_column($problem_pos); my $lexer_name; my @details = (); my %rejections = (); my @events = $thin_slr->events() ; if (scalar @events > 100) { my $omitted = scalar @events - 100; push @details, " [there were $omitted events -- only the first 100 were examined]"; $#events = 99; } EVENT: for my $event ( @events ) { my ( $event_type, $trace_event_type, $lexeme_start_pos, $lexeme_end_pos, $g1_lexeme, $lexer_id ) = @{$event}; next EVENT if $event_type ne q{'trace} or $trace_event_type ne 'rejected lexeme'; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $raw_token_value = $thin_slr->substring( $lexeme_start_pos, $lexeme_end_pos - $lexeme_start_pos ); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_grammar = $thick_g1_recce->grammar(); my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; # Different internal symbols may have the same external "display form", # which in naive reporting logic would result in many identical messages, # confusing the user. This logic makes sure that identical rejection # reports are not repeated, even when they have different causes # internally. $rejections{qq{Lexer "} . $lexer_name . q{"; } . $thick_g1_grammar->symbol_in_display_form($g1_lexeme) . qq{; value="$raw_token_value"; length = } . ( $lexeme_end_pos - $lexeme_start_pos )} = 1; } ## end EVENT: for my $event ( $thin_slr->events() ) my @problem = (); my @rejections = keys %rejections; if (scalar @rejections) { my $rejection_count = scalar @rejections; push @problem, "No lexemes accepted at line $line, column $column"; REJECTION: for my $i (0 .. 5) { my $rejection = $rejections[$i]; last REJECTION if not defined $rejection; push @problem, qq{ Rejected lexeme #$i: $rejection}; } if ($rejection_count > 5) { push @problem, " [there were $rejection_count rejection messages -- only the first 5 are shown]"; } push @problem, @details; } ## end if ($rejected_count) else { push @problem, "No lexeme found at line $line, column $column"; } $problem = join "\n", @problem; last CODE_TO_PROBLEM; } ## end if ( $problem_code eq 'no lexemes accepted' ) $problem = 'Unrecognized problem code: ' . $problem_code; } ## end CODE_TO_PROBLEM: my $desc; DESC: { if ( defined $problem ) { $desc .= "$problem"; } if ( $stream_status == -1 ) { $desc = 'Lexer: Character rejected'; last DESC; } if ( $stream_status == -2 ) { $desc = 'Lexer: Unregistered character'; last DESC; } # -5 indicates success, in which case we should never have called this subroutine. if ( $stream_status == -3 || $stream_status == -5 ) { $desc = 'Unexpected return value from lexer: Parse exhausted'; last DESC; } if ($g1_status) { my $true_event_count = $thin_slr->g1()->event_count(); EVENT: for ( my $event_ix = 0; $event_ix < $true_event_count; $event_ix++ ) { my ( $event_type, $value ) = $thin_slr->g1()->event($event_ix); if ( $event_type eq 'MARPA_EVENT_EARLEY_ITEM_THRESHOLD' ) { $desc = join "\n", $desc, "G1 grammar: Earley item count ($value) exceeds warning threshold\n"; next EVENT; } if ( $event_type eq 'MARPA_EVENT_SYMBOL_EXPECTED' ) { $desc = join "\n", $desc, "Unexpected G1 grammar event: $event_type " . $g1_tracer->symbol_name($value); next EVENT; } ## end if ( $event_type eq 'MARPA_EVENT_SYMBOL_EXPECTED' ) if ( $event_type eq 'MARPA_EVENT_EXHAUSTED' ) { $desc = join "\n", $desc, 'Parse exhausted'; next EVENT; } Marpa::R2::exception( $desc, "\n", qq{Unknown event: "$event_type"; event value = $value\n} ); } ## end EVENT: for ( my $event_ix = 0; $event_ix < ...) last DESC; } ## end if ($g1_status) if ( $g1_status < 0 ) { $desc = 'G1 error: ' . $thin_slr->g1()->error(); chomp $desc; last DESC; } } ## end DESC: my $read_string_error; if ( $problem_pos < $length_of_string) { my $char = substr ${$p_string}, $problem_pos, 1; my $char_desc = character_describe($char); my ( $line, $column ) = $thin_slr->line_column($problem_pos); my $prefix = $problem_pos >= 50 ? ( substr ${$p_string}, $problem_pos - 50, 50 ) : ( substr ${$p_string}, 0, $problem_pos ); $read_string_error = "Error in SLIF parse: $desc\n" . '* String before error: ' . Marpa::R2::escape_string( $prefix, -50 ) . "\n" . "* The error was at line $line, column $column, and at character $char_desc, ...\n" . '* here: ' . Marpa::R2::escape_string( ( substr ${$p_string}, $problem_pos, 50 ), 50 ) . "\n"; } ## end elsif ( $problem_pos < $length_of_string ) else { $read_string_error = "Error in SLIF parse: $desc\n" . "* Error was at end of input\n" . '* String before error: ' . Marpa::R2::escape_string( ${$p_string}, -50 ) . "\n"; } ## end else [ if ($g1_status) ] if ( $slr->[Marpa::R2::Internal::Scanless::R::TRACE_LEXERS] ) { my $stream_pos = $thin_slr->pos(); my $trace_file_handle = $slr->[Marpa::R2::Internal::Scanless::R::TRACE_FILE_HANDLE]; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $lexer_id = $thin_slr->current_lexer(); my $thick_lex_grammar = $grammar->[Marpa::R2::Internal::Scanless::G::THICK_LEX_GRAMMARS]->[$lexer_id]; my $lex_tracer = $thick_lex_grammar->tracer(); my $lexer_name = $slg->[Marpa::R2::Internal::Scanless::G::LEXER_NAME_BY_ID] ->[$lexer_id]; my ( $line, $column ) = $slr->line_column($stream_pos); $read_string_error .= qq{\n=== Progress report for lexer "$lexer_name" at line $line, column $column\n} . $lex_tracer->lexer_progress_report($slr); } $slr->[Marpa::R2::Internal::Scanless::R::READ_STRING_ERROR] = $read_string_error; Marpa::R2::exception($read_string_error); # Never reached # Fall through to return undef return; } ## end sub Marpa::R2::Scanless::R::read_problem sub character_describe { my ($char) = @_; my $text = sprintf '0x%04x', ord $char; $text .= q{ } . ( $char =~ m/[[:graph:]]/xms ? qq{'$char'} : '(non-graphic character)' ); return $text; } ## end sub character_describe my @escape_by_ord = (); $escape_by_ord[ ord q{\\} ] = q{\\\\}; $escape_by_ord[ ord eval qq{"$_"} ] = $_ for "\\t", "\\r", "\\f", "\\b", "\\a", "\\e"; $escape_by_ord[0xa] = '\\n'; $escape_by_ord[$_] //= chr $_ for 32 .. 126; $escape_by_ord[$_] //= sprintf( "\\x%02x", $_ ) for 0 .. 255; # This and the sister routine for "forward strings" # should replace the other string "escaping" subroutine # in the NAIF sub Marpa::R2::Internal::Scanless::reversed_input_escape { my ( $p_input, $base_pos, $length ) = @_; my @escaped_chars = (); my $pos = $base_pos - 1 ; my $trailing_spaces = 0; CHAR: while ( $pos > 0 ) { last CHAR if substr ${$p_input}, $pos, 1 ne q{ }; $trailing_spaces++; $pos--; } my $length_so_far = $trailing_spaces * 2; CHAR: while ( $pos >= 0 ) { my $char = substr ${$p_input}, $pos, 1; my $ord = ord $char; my $escaped_char = $escape_by_ord[$ord] // sprintf( "\\x{%04x}", $ord ); my $char_length = length $escaped_char; $length_so_far += $char_length; last CHAR if $length_so_far > $length; push @escaped_chars, $escaped_char; $pos--; } ## end CHAR: while ( $pos > 0 and $pos < $end_of_input ) @escaped_chars = reverse @escaped_chars; push @escaped_chars, '\\s' for 1 .. $trailing_spaces; return join q{}, @escaped_chars; } ## end sub Marpa::R2::Internal::Scanless::input_escape sub Marpa::R2::Internal::Scanless::input_escape { my ( $p_input, $base_pos, $length ) = @_; my @escaped_chars = (); my $pos = $base_pos; my $length_so_far = 0; my $end_of_input = length ${$p_input}; CHAR: while ( $pos < $end_of_input ) { my $char = substr ${$p_input}, $pos, 1; my $ord = ord $char; my $escaped_char = $escape_by_ord[$ord] // sprintf( "\\x{%04x}", $ord ); my $char_length = length $escaped_char; $length_so_far += $char_length; last CHAR if $length_so_far > $length; push @escaped_chars, $escaped_char; $pos++; } ## end CHAR: while ( $pos < $end_of_input ) my $first_non_space_ix = $#escaped_chars; my $trailing_spaces = 0; $trailing_spaces++ while $escaped_chars[ $first_non_space_ix-- ] eq q{ }; if ($trailing_spaces) { splice @escaped_chars, -$trailing_spaces; $length_so_far -= $trailing_spaces; TRAILING_SPACE: while ( $trailing_spaces-- > 0 ) { $length_so_far += 2; last TRAILING_SPACE if $length_so_far > $length; push @escaped_chars, '\\s'; } } ## end if ($trailing_spaces) return join q{}, @escaped_chars; } ## end sub Marpa::R2::Internal::Scanless::input_escape sub Marpa::R2::Scanless::R::ambiguity_metric { my ($slr) = @_; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; $thick_g1_recce->ordering_create(); my $ordering = $thick_g1_recce->[Marpa::R2::Internal::Recognizer::O_C]; return 0 if not $ordering; return $ordering->ambiguity_metric(); } ## end sub Marpa::R2::Scanless::R::ambiguity_metric sub Marpa::R2::Scanless::R::rule_closure { my ( $slr, $rule_id ) = @_; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; if ( not $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] ) { my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $per_parse_arg = {}; my $trace_actions = $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0; my $trace_file_handle = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE]; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; Marpa::R2::Internal::Value::registration_init( $recce, $per_parse_arg ); } ## end if ( not $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS...]) my $rule_closure = $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_RULE_ID]->[$rule_id]; if (defined $rule_closure){ my $ref_rule_closure = ref $rule_closure; if ( $ref_rule_closure eq 'CODE' ){ return $rule_closure; } elsif ( $ref_rule_closure eq 'SCALAR' ){ return $rule_closure; } } else{ return } } ## end sub Marpa::R2::Scanless::R::rule_closure sub Marpa::R2::Scanless::R::value { my ( $slr, $per_parse_arg ) = @_; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thick_g1_value = $thick_g1_recce->value( $slr, $per_parse_arg ); return $thick_g1_value; } ## end sub Marpa::R2::Scanless::R::value sub Marpa::R2::Scanless::R::series_restart { my ( $slr , @args ) = @_; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; $thick_g1_recce->reset_evaluation(); my $g1_recce_args = Marpa::R2::Internal::Scanless::R::set($slr, "series_restart", @args ); $thick_g1_recce->set( $g1_recce_args ); return 1; } # Given a list of G1 locations, return the minimum span in the input string # that includes them all # Caller must ensure that there is an input, which is not the case # when the parse is initialized. sub g1_locations_to_input_range { my ( $slr, @g1_locations ) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $first_pos = $thin_slr->input_length(); my $last_pos = 0; for my $g1_location (@g1_locations) { my ( $input_start, $input_length ) = $thin_slr->span($g1_location); my $input_end = $input_length ? $input_start + $input_length - 1 : $input_start; $first_pos = $input_start if $input_start < $first_pos; $last_pos = $input_end if $input_end > $last_pos; } ## end for my $g1_location (@other_g1_locations) return ($first_pos, $last_pos); } sub input_range_describe { my ( $slr, $first_pos, $last_pos ) = @_; my ( $first_line, $first_column ) = $slr->line_column($first_pos); my ( $last_line, $last_column ) = $slr->line_column($last_pos); if ( $first_line == $last_line ) { return join q{}, 'L', $first_line, 'c', $first_column if $first_column == $last_column; return join q{}, 'L', $first_line, 'c', $first_column, '-', $last_column; } ## end if ( $first_line == $last_line ) return join q{}, 'L', $first_line, 'c', $first_column, '-L', $last_line, 'c', $last_column; } ## end sub input_range_describe sub Marpa::R2::Scanless::R::show_progress { my ( $slr, $start_ordinal, $end_ordinal ) = @_; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $last_ordinal = $recce->latest_earley_set(); if ( not defined $start_ordinal ) { $start_ordinal = $last_ordinal; } if ( $start_ordinal < 0 ) { $start_ordinal += $last_ordinal + 1; } else { if ( $start_ordinal < 0 or $start_ordinal > $last_ordinal ) { return "Marpa::PP::Recognizer::show_progress start index is $start_ordinal, " . "must be in range 0-$last_ordinal"; } } ## end else [ if ( $start_ordinal < 0 ) ] if ( not defined $end_ordinal ) { $end_ordinal = $start_ordinal; } else { my $end_ordinal_argument = $end_ordinal; if ( $end_ordinal < 0 ) { $end_ordinal += $last_ordinal + 1; } if ( $end_ordinal < 0 ) { return "Marpa::PP::Recognizer::show_progress end index is $end_ordinal_argument, " . sprintf ' must be in range %d-%d', -( $last_ordinal + 1 ), $last_ordinal; } ## end if ( $end_ordinal < 0 ) } ## end else [ if ( not defined $end_ordinal ) ] my $text = q{}; for my $current_ordinal ( $start_ordinal .. $end_ordinal ) { my $current_earleme = $recce->earleme($current_ordinal); my %by_rule_by_position = (); for my $progress_item ( @{ $recce->progress($current_ordinal) } ) { my ( $rule_id, $position, $origin ) = @{$progress_item}; if ( $position < 0 ) { $position = $grammar_c->rule_length($rule_id); } $by_rule_by_position{$rule_id}->{$position}->{$origin}++; } ## end for my $progress_item ( @{ $recce->progress($current_ordinal...)}) for my $rule_id ( sort { $a <=> $b } keys %by_rule_by_position ) { my $by_position = $by_rule_by_position{$rule_id}; for my $position ( sort { $a <=> $b } keys %{$by_position} ) { my $raw_origins = $by_position->{$position}; my @origins = sort { $a <=> $b } keys %{$raw_origins}; my $origins_count = scalar @origins; my $origin_desc; if ( $origins_count <= 3 ) { $origin_desc = join q{,}, @origins; } else { $origin_desc = $origins[0] . q{...} . $origins[-1]; } my $rhs_length = $grammar_c->rule_length($rule_id); my @item_text; if ( $position >= $rhs_length ) { push @item_text, "F$rule_id"; } elsif ($position) { push @item_text, "R$rule_id:$position"; } else { push @item_text, "P$rule_id"; } push @item_text, "x$origins_count" if $origins_count > 1; push @item_text, q{@} . $origin_desc . q{-} . $current_earleme; if ( $current_earleme > 0 ) { my $input_range = input_range_describe( $slr, g1_locations_to_input_range( $slr, $current_earleme, @origins ) ); push @item_text, $input_range; } else { push @item_text, 'L0c0'; } push @item_text, $slg->show_dotted_rule( $rule_id, $position ); $text .= ( join q{ }, @item_text ) . "\n"; } ## end for my $position ( sort { $a <=> $b } keys %{...}) } ## end for my $rule_id ( sort { $a <=> $b } keys ...) } ## end for my $current_ordinal ( $start_ordinal .. $end_ordinal) return $text; } sub Marpa::R2::Scanless::R::progress { my ( $self, @args ) = @_; return $self->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE] ->progress(@args); } sub Marpa::R2::Scanless::R::terminals_expected { my ($self) = @_; return $self->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE] ->terminals_expected(); } sub Marpa::R2::Scanless::R::exhausted { my ($self) = @_; return $self->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE] ->exhausted(); } # Latest and current G1 location are the same sub Marpa::R2::Scanless::R::latest_g1_location { my ($slg) = @_; return $slg->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE] ->latest_earley_set(); } # Latest and current G1 location are the same sub Marpa::R2::Scanless::R::current_g1_location { my ($slg) = @_; return $slg->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE] ->latest_earley_set(); } sub Marpa::R2::Scanless::R::lexeme_alternative { my ( $slr, $symbol_name, @value ) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; Marpa::R2::exception( "slr->alternative(): symbol name is undefined\n", " The symbol name cannot be undefined\n" ) if not defined $symbol_name; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $g1_grammar = $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR]; my $g1_tracer = $g1_grammar->tracer(); my $symbol_id = $g1_tracer->symbol_by_name($symbol_name); if ( not defined $symbol_id ) { Marpa::R2::exception( qq{slr->alternative(): symbol "$symbol_name" does not exist}); } my $result = $thin_slr->g1_alternative( $symbol_id, @value ); return 1 if $result == $Marpa::R2::Error::NONE; # The last two are perhaps unnecessary or arguable, # but they preserve compatibility with Marpa::XS return if $result == $Marpa::R2::Error::UNEXPECTED_TOKEN_ID || $result == $Marpa::R2::Error::NO_TOKEN_EXPECTED_HERE || $result == $Marpa::R2::Error::INACCESSIBLE_TOKEN; Marpa::R2::exception( qq{Problem reading symbol "$symbol_name": }, ( scalar $g1_grammar->error() ) ); } ## end sub Marpa::R2::Scanless::R::lexeme_alternative # Returns 0 on unthrown failure, current location on success sub Marpa::R2::Scanless::R::lexeme_complete { my ( $slr, $start, $length ) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; $slr->[Marpa::R2::Internal::Scanless::R::EVENTS] = []; my $return_value = $thin_slr->g1_lexeme_complete( $start, $length ); Marpa::R2::Internal::Scanless::convert_libmarpa_events($slr); return $return_value; } ## end sub Marpa::R2::Scanless::R::lexeme_complete # Returns 0 on unthrown failure, current location on success, # undef if lexeme not accepted. sub Marpa::R2::Scanless::R::lexeme_read { my ( $slr, $symbol_name, $start, $length, @value ) = @_; return if not $slr->lexeme_alternative( $symbol_name, @value ); return $slr->lexeme_complete( $start, $length ); } sub Marpa::R2::Scanless::R::pause_span { my ($slr) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; return $thin_slr->pause_span(); } sub Marpa::R2::Scanless::R::pause_lexeme { my ($slr) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $grammar = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thick_g1_grammar = $grammar->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR]; my $g1_tracer = $thick_g1_grammar->tracer(); my $symbol = $thin_slr->pause_lexeme(); return if not defined $symbol; return $g1_tracer->symbol_name($symbol); } ## end sub Marpa::R2::Scanless::R::pause_lexeme sub Marpa::R2::Scanless::R::line_column { my ( $slr, $pos ) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; $pos //= $thin_slr->pos(); return $thin_slr->line_column($pos); } ## end sub Marpa::R2::Scanless::R::line_column sub Marpa::R2::Scanless::R::pos { my ( $slr ) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; return $thin_slr->pos(); } sub Marpa::R2::Scanless::R::input_length { my ( $slr ) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; return $thin_slr->input_length(); } # no return value documented sub Marpa::R2::Scanless::R::activate { my ( $slr, $event_name, $activate ) = @_; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; $activate //= 1; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $thin_g1_recce = $thick_g1_recce->thin(); my $event_symbol_ids_by_type = $slg ->[Marpa::R2::Internal::Scanless::G::SYMBOL_IDS_BY_EVENT_NAME_AND_TYPE] ->{$event_name}; $thin_g1_recce->completion_symbol_activate( $_, $activate ) for @{ $event_symbol_ids_by_type->{completion} }; $thin_g1_recce->nulled_symbol_activate( $_, $activate ) for @{ $event_symbol_ids_by_type->{nulled} }; $thin_g1_recce->prediction_symbol_activate( $_, $activate ) for @{ $event_symbol_ids_by_type->{prediction} }; $thin_slr->lexeme_event_activate( $_, $activate ) for @{ $event_symbol_ids_by_type->{lexeme} }; return 1; } ## end sub Marpa::R2::Scanless::R::activate # Internal methods, not to be documented sub Marpa::R2::Scanless::R::thick_g1_grammar { my ($slr) = @_; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; return $slg->[Marpa::R2::Internal::Scanless::G::THICK_G1_GRAMMAR]; } sub Marpa::R2::Scanless::R::thick_g1_recce { my ($slr) = @_; return $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; } sub Marpa::R2::Scanless::R::default_g1_start_closure { my ($slr) = @_; my $slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]; my $default_action_name = $slg->[Marpa::R2::Internal::Scanless::G::DEFAULT_G1_START_ACTION]; my $thick_g1_recce = $slr->[Marpa::R2::Internal::Scanless::R::THICK_G1_RECCE]; my $resolution = Marpa::R2::Internal::Recognizer::resolve_action( $thick_g1_recce, $default_action_name ); return if not $resolution; my ( undef, $closure ) = @{$resolution}; return $closure; } ## end sub Marpa::R2::Scanless::R::default_g1_start_closure 1; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/Value.pm0000444000000000000000000026103512342464706016552 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::Value; use 5.010; use warnings; use strict; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic package Marpa::R2::Internal::Value; use English qw( -no_match_vars ); use constant SKIP => -1; sub Marpa::R2::show_rank_ref { my ($rank_ref) = @_; return 'undef' if not defined $rank_ref; return 'SKIP' if $rank_ref == Marpa::R2::Internal::Value::SKIP; return ${$rank_ref}; } ## end sub Marpa::R2::show_rank_ref package Marpa::R2::Internal::Value; # Given the grammar and an action name, resolve it to a closure, # or return undef sub Marpa::R2::Internal::Recognizer::resolve_action { my ( $recce, $closure_name, $p_error ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $closures = $recce->[Marpa::R2::Internal::Recognizer::CLOSURES]; my $trace_actions = $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS]; # A reserved closure name; return [ q{}, undef, '::!default' ] if not defined $closure_name; if ( $closure_name eq q{} ) { ${$p_error} = q{The action string cannot be the empty string} if defined $p_error; return; } return [ q{}, \undef, $closure_name ] if $closure_name eq '::undef'; if ( substr( $closure_name, 0, 2 ) eq q{::} or substr( $closure_name, 0, 1 ) eq '[' ) { return [ q{}, undef, $closure_name ]; } if ( my $closure = $closures->{$closure_name} ) { if ($trace_actions) { print {$Marpa::R2::Internal::TRACE_FH} qq{Resolved "$closure_name" to explicit closure\n} or Marpa::R2::exception('Could not print to trace file'); } return [ $closure_name, $closure, '::array' ]; } ## end if ( my $closure = $closures->{$closure_name} ) my $fully_qualified_name; if ( $closure_name =~ /([:][:])|[']/xms ) { $fully_qualified_name = $closure_name; } if (not $fully_qualified_name) { my $resolve_package = $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE]; if (not defined $resolve_package) { ${$p_error} = Marpa::R2::Internal::X->new( { message => qq{Could not fully qualify "$closure_name": no resolve package}, name => 'NO RESOLVE PACKAGE' } ); return; } $fully_qualified_name = $resolve_package . q{::} . $closure_name; } my $closure; my $type; TYPE: { no strict 'refs'; $closure = *{$fully_qualified_name}{'CODE'}; use strict; if ( defined $closure ) { $type = 'CODE'; last TYPE; } no strict 'refs'; $closure = *{$fully_qualified_name}{'SCALAR'}; use strict; # Currently $closure is always defined, but this # behavior is said to be subject to change in perlref if ( defined $closure and defined ${$closure} ) { $type = 'SCALAR'; last TYPE; } # Re other symbol tables entries: # We ignore ARRAY and HASH because they anything # we resolve to is a potential array entry, something # that not possible for arrays and hashes except # indirectly, via references. # FORMAT is deprecated. # IO and GLOB seem too abstruse at the moment. $closure = undef; } ## end TYPE: if ( defined $closure ) { if ($trace_actions) { print {$Marpa::R2::Internal::TRACE_FH} qq{Successful resolution of action "$closure_name" as $type }, 'to ', $fully_qualified_name, "\n" or Marpa::R2::exception('Could not print to trace file'); } ## end if ($trace_actions) return [ $fully_qualified_name, $closure, '::array' ]; } ## end if ( defined $closure ) if ( $trace_actions or defined $p_error ) { for my $slot (qw(ARRAY HASH IO FORMAT)) { no strict 'refs'; if ( defined *{$fully_qualified_name}{$slot} ) { my $error = qq{Failed resolution of action "$closure_name" to $fully_qualified_name\n} . qq{ $fully_qualified_name is present as a $slot, but a $slot is not an acceptable resolution\n}; if ($trace_actions) { print {$Marpa::R2::Internal::TRACE_FH} $error or Marpa::R2::exception('Could not print to trace file'); } ${$p_error} = $error if defined $p_error; return; } ## end if ( defined *{$fully_qualified_name}{$slot} ) } ## end for my $slot (qw(ARRAY HASH IO FORMAT)) } ## end if ( $trace_actions or defined $p_error ) { my $error = qq{Failed resolution of action "$closure_name" to $fully_qualified_name\n}; ${$p_error} = $error if defined $p_error; if ($trace_actions) { print {$Marpa::R2::Internal::TRACE_FH} $error or Marpa::R2::exception('Could not print to trace file'); } } return; } ## end sub Marpa::R2::Internal::Recognizer::resolve_action # Find the semantics for a lexeme. sub Marpa::R2::Internal::Recognizer::lexeme_semantics_find { my ( $recce, $lexeme_id ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $symbol = $symbols->[$lexeme_id]; my $semantics = $symbol->[Marpa::R2::Internal::Symbol::LEXEME_SEMANTICS]; return '::!default' if not defined $semantics; return $semantics; } ## end sub Marpa::R2::Internal::Recognizer::lexeme_semantics_find # Find the blessing for a rule. sub Marpa::R2::Internal::Recognizer::rule_blessing_find { my ( $recce, $rule_id ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $rule = $rules->[$rule_id]; my $blessing = $rule->[Marpa::R2::Internal::Rule::BLESSING]; $blessing = '::undef' if not defined $blessing; return $blessing if $blessing eq '::undef'; my $bless_package = $grammar->[Marpa::R2::Internal::Grammar::BLESS_PACKAGE]; if ( not defined $bless_package ) { Marpa::R2::exception( qq{A blessed rule is in a grammar with no bless_package\n} . qq{ The rule was blessed as "$blessing"\n} ); } ## end if ( not defined $bless_package ) return join q{}, $bless_package, q{::}, $blessing; } ## end sub Marpa::R2::Internal::Recognizer::rule_blessing_find # Find the blessing for a lexeme. sub Marpa::R2::Internal::Recognizer::lexeme_blessing_find { my ( $recce, $lexeme_id ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $symbol = $symbols->[$lexeme_id]; my $blessing = $symbol->[Marpa::R2::Internal::Symbol::BLESSING]; return '::undef' if not defined $blessing; return '::undef' if $blessing eq '::undef'; if ( $blessing =~ m/\A [:][:] /xms ) { my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $lexeme_name = $tracer->symbol_name($lexeme_id); $recce->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE] = qq{Symbol "$lexeme_name" has unknown blessing: "$blessing"}; return; } ## end if ( $blessing =~ m/\A [:][:] /xms ) if ( $blessing =~ m/ [:][:] /xms ) { return $blessing; } my $bless_package = $grammar->[Marpa::R2::Internal::Grammar::BLESS_PACKAGE]; if ( not defined $bless_package ) { my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $lexeme_name = $tracer->symbol_name($lexeme_id); $recce->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE] = qq{Symbol "$lexeme_name" needs a blessing package, but grammar has none\n} . qq{ The blessing for "$lexeme_name" was "$blessing"\n}; return; } ## end if ( not defined $bless_package ) return $bless_package . q{::} . $blessing; } ## end sub Marpa::R2::Internal::Recognizer::lexeme_blessing_find # For diagnostics sub Marpa::R2::Internal::Recognizer::brief_rule_list { my ( $recce, $rule_ids ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my @brief_rules = map { $grammar->brief_rule($_) } @{$rule_ids}; return join q{}, map { q{ } . $_ . "\n" } @brief_rules; } ## end sub Marpa::R2::Internal::Recognizer::brief_rule_list our $CONTEXT_EXCEPTION_CLASS = __PACKAGE__ . '::Context_Exception'; sub Marpa::R2::Context::bail { ## no critic (Subroutines::RequireArgUnpacking) if ( scalar @_ == 1 and ref $_[0] ) { die bless { exception_object => $_[0] }, $CONTEXT_EXCEPTION_CLASS; } my $error_string = join q{}, @_; my ( $package, $filename, $line ) = caller; chomp $error_string; die bless { message => qq{User bailed at line $line in file "$filename"\n} . $error_string . "\n" }, $CONTEXT_EXCEPTION_CLASS; } ## end sub Marpa::R2::Context::bail ## use critic sub Marpa::R2::Context::location { my $valuator = $Marpa::R2::Internal::Context::VALUATOR; Marpa::R2::exception( 'Marpa::R2::Context::location called outside of a valuation context') if not defined $valuator; return $valuator->location(); } ## end sub Marpa::R2::Context::location sub code_problems { my $args = shift; my $grammar; my $fatal_error; my $warnings = []; my $where = '?where?'; my $long_where; my @msg = (); my $eval_value; my $eval_given = 0; push @msg, q{=} x 60, "\n"; ARG: for my $arg ( keys %{$args} ) { my $value = $args->{$arg}; if ( $arg eq 'fatal_error' ) { $fatal_error = $value; next ARG } if ( $arg eq 'grammar' ) { $grammar = $value; next ARG } if ( $arg eq 'where' ) { $where = $value; next ARG } if ( $arg eq 'long_where' ) { $long_where = $value; next ARG } if ( $arg eq 'warnings' ) { $warnings = $value; next ARG } if ( $arg eq 'eval_ok' ) { $eval_value = $value; $eval_given = 1; next ARG; } push @msg, "Unknown argument to code_problems: $arg"; } ## end ARG: for my $arg ( keys %{$args} ) GIVEN_FATAL_ERROR_REF_TYPE: { my $fatal_error_ref_type = ref $fatal_error; last GIVEN_FATAL_ERROR_REF_TYPE if not $fatal_error_ref_type; if ( $fatal_error_ref_type eq $CONTEXT_EXCEPTION_CLASS ) { my $exception_object = $fatal_error->{exception_object}; die $exception_object if defined $exception_object; my $exception_message = $fatal_error->{message}; die $exception_message if defined $exception_message; die "Internal error: bad $CONTEXT_EXCEPTION_CLASS object"; } ## end if ( $fatal_error_ref_type eq $CONTEXT_EXCEPTION_CLASS) $fatal_error = "Exception thrown as object inside Marpa closure\n" . ( q{ } x 4 ) . "This is not allowed\n" . ( q{ } x 4 ) . qq{Exception as string is "$fatal_error"}; } ## end GIVEN_FATAL_ERROR_REF_TYPE: my @problem_line = (); my $max_problem_line = -1; for my $warning_data ( @{$warnings} ) { my ( $warning, $package, $filename, $problem_line ) = @{$warning_data}; $problem_line[$problem_line] = 1; $max_problem_line = List::Util::max $problem_line, $max_problem_line; } ## end for my $warning_data ( @{$warnings} ) $long_where //= $where; my $warnings_count = scalar @{$warnings}; { my @problems; my $false_eval = $eval_given && !$eval_value && !$fatal_error; if ($false_eval) { push @problems, '* THE MARPA SEMANTICS RETURNED A PERL FALSE', 'Marpa::R2 requires its semantics to return a true value'; } if ($fatal_error) { push @problems, '* THE MARPA SEMANTICS PRODUCED A FATAL ERROR'; } if ($warnings_count) { push @problems, "* THERE WERE $warnings_count WARNING(S) IN THE MARPA SEMANTICS:", 'Marpa treats warnings as fatal errors'; } if ( not scalar @problems ) { push @msg, '* THERE WAS A FATAL PROBLEM IN THE MARPA SEMANTICS'; } push @msg, ( join "\n", @problems ) . "\n"; } push @msg, "* THIS IS WHAT MARPA WAS DOING WHEN THE PROBLEM OCCURRED:\n" . $long_where . "\n"; for my $warning_ix ( 0 .. ( $warnings_count - 1 ) ) { push @msg, "* WARNING MESSAGE NUMBER $warning_ix:\n"; my $warning_message = $warnings->[$warning_ix]->[0]; $warning_message =~ s/\n*\z/\n/xms; push @msg, $warning_message; } ## end for my $warning_ix ( 0 .. ( $warnings_count - 1 ) ) if ($fatal_error) { push @msg, "* THIS WAS THE FATAL ERROR MESSAGE:\n"; my $fatal_error_message = $fatal_error; $fatal_error_message =~ s/\n*\z/\n/xms; push @msg, $fatal_error_message; } ## end if ($fatal_error) Marpa::R2::exception(@msg); # this is to keep perlcritic happy return 1; } ## end sub code_problems # Dump semnatics for diagnostics sub show_semantics { my (@ops) = @_; my @op_descs = (); my $op_ix = 0; OP: while ( $op_ix < scalar @ops ) { my $op = $ops[ $op_ix++ ]; my $op_name = Marpa::R2::Thin::op_name($op); push @op_descs, $op_name; if ( $op_name eq 'bless' ) { push @op_descs, q{"} . $ops[$op_ix] . q{"}; $op_ix++; next OP; } if ( $op_name eq 'push_constant' ) { push @op_descs, $ops[$op_ix]; $op_ix++; next OP; } if ( $op_name eq 'push_one' ) { push @op_descs, $ops[$op_ix]; $op_ix++; next OP; } if ( $op_name eq 'result_is_rhs_n' ) { push @op_descs, $ops[$op_ix]; $op_ix++; next OP; } if ( $op_name eq 'result_is_n_of_sequence' ) { push @op_descs, $ops[$op_ix]; $op_ix++; next OP; } if ( $op_name eq 'result_is_constant' ) { push @op_descs, $ops[$op_ix]; $op_ix++; next OP; } if ( $op_name eq 'alternative' ) { push @op_descs, $ops[$op_ix]; $op_ix++; push @op_descs, $ops[$op_ix]; $op_ix++; next OP; } ## end if ( $op_name eq 'alternative' ) } ## end OP: while ( $op_ix < scalar @ops ) return join q{ }, @op_descs; } ## end sub show_semantics sub Marpa::R2::Recognizer::ordering_create { my ($recce) = @_; return if $recce->[Marpa::R2::Internal::Recognizer::NO_PARSE]; my $parse_set_arg = $recce->[Marpa::R2::Internal::Recognizer::END_OF_PARSE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; $grammar_c->throw_set(0); my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C] = Marpa::R2::Thin::B->new( $recce_c, ( $parse_set_arg // -1 ) ); $grammar_c->throw_set(1); if ( not $bocage ) { $recce->[Marpa::R2::Internal::Recognizer::NO_PARSE] = 1; return; } $recce->[Marpa::R2::Internal::Recognizer::O_C] = Marpa::R2::Thin::O->new($bocage); GIVEN_RANKING_METHOD: { my $ranking_method = $recce->[Marpa::R2::Internal::Recognizer::RANKING_METHOD]; if ( $ranking_method eq 'high_rule_only' ) { do_high_rule_only($recce); last GIVEN_RANKING_METHOD; } if ( $ranking_method eq 'rule' ) { do_rank_by_rule($recce); last GIVEN_RANKING_METHOD; } } ## end GIVEN_RANKING_METHOD: return 1; } ## end sub Marpa::R2::Recognizer::ordering_create sub resolve_rule_by_id { my ( $recce, $rule_id ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $rule = $rules->[$rule_id]; my $action_name = $rule->[Marpa::R2::Internal::Rule::ACTION_NAME]; my $resolve_error; return if not defined $action_name; my $resolution = Marpa::R2::Internal::Recognizer::resolve_action( $recce, $action_name, \$resolve_error ); if ( not $resolution ) { my $rule_desc = rule_describe($grammar, $rule_id); Marpa::R2::exception( "Could not resolve rule action named '$action_name'\n", " Rule was $rule_desc\n", q{ }, ( $resolve_error // 'Failed to resolve action' ) ); } ## end if ( not $resolution ) return $resolution; } ## end sub resolve_rule_by_id # For error messages -- checks if it is called in context with # SLR defined sub rule_describe { my ( $grammar, $rule_id ) = @_; return $Marpa::R2::Context::slr->rule_show($rule_id) if $Marpa::R2::Context::slr; return $grammar->rule_describe($rule_id); } ## end sub rule_describe sub resolve_recce { my ($recce, $per_parse_arg) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $trace_actions = $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0; my $trace_file_handle = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE]; my $package_source = $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE]; if ( not defined $package_source ) { DETERMINE_RESOLVE_PACKAGE_SOURCE: { if ( defined $per_parse_arg ) { if ( my $arg_blessing = Scalar::Util::blessed $per_parse_arg) { $recce->[ Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE] = $arg_blessing; $package_source = 'arg'; last DETERMINE_RESOLVE_PACKAGE_SOURCE; } ## end if ( my $arg_blessing = Scalar::Util::blessed ...) $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE] = $recce ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE]; $package_source = 'semantics_package'; last DETERMINE_RESOLVE_PACKAGE_SOURCE; } ## end if ( defined $per_parse_arg ) $package_source = 'legacy'; } ## end DETERMINE_RESOLVE_PACKAGE_SOURCE: $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE] = $package_source; } ## end if ( not defined $package_source ) if ( $package_source eq 'legacy' ) { # RESOLVE_PACKAGE is already set if not 'legacy' $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE] = $grammar->[Marpa::R2::Internal::Grammar::ACTIONS] // $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT]; } ## end if ( $package_source eq 'legacy' ) FIND_CONSTRUCTOR: { my $constructor_package = ( $package_source eq 'legacy' ) ? $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT] : $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE]; last FIND_CONSTRUCTOR if not defined $constructor_package; my $constructor_name = $constructor_package . q{::new}; my $resolve_error; my $resolution = Marpa::R2::Internal::Recognizer::resolve_action( $recce, $constructor_name, \$resolve_error ); if ($resolution) { $recce->[ Marpa::R2::Internal::Recognizer::PER_PARSE_CONSTRUCTOR ] = $resolution->[1]; last FIND_CONSTRUCTOR; } ## end if ($resolution) last FIND_CONSTRUCTOR if $package_source ne 'legacy'; Marpa::R2::exception( qq{Could not find constructor "$constructor_name"}, q{ }, ( $resolve_error // 'Failed to resolve action' ) ); } ## end FIND_CONSTRUCTOR: my $resolve_error; my $default_action = $grammar->[Marpa::R2::Internal::Grammar::DEFAULT_ACTION]; my $default_action_resolution = Marpa::R2::Internal::Recognizer::resolve_action( $recce, $default_action, \$resolve_error ); Marpa::R2::exception( "Could not resolve default action named '$default_action'\n", q{ }, ( $resolve_error // 'Failed to resolve action' ) ) if not $default_action_resolution; my $default_empty_action = $grammar->[Marpa::R2::Internal::Grammar::DEFAULT_EMPTY_ACTION]; my $default_empty_action_resolution; if ($default_empty_action) { $default_empty_action_resolution = Marpa::R2::Internal::Recognizer::resolve_action( $recce, $default_empty_action, \$resolve_error ); Marpa::R2::exception( "Could not resolve default empty rule action named '$default_empty_action'", q{ }, ( $resolve_error // 'Failed to resolve action' ) ) if not $default_empty_action_resolution; } ## end if ($default_empty_action) my $rule_resolutions = []; RULE: for my $rule_id ( $grammar->rule_ids() ) { my $rule_resolution = resolve_rule_by_id( $recce, $rule_id ); if ( not defined $rule_resolution and $default_empty_action and $grammar_c->rule_length($rule_id) == 0 ) { $rule_resolution = $default_empty_action_resolution; } ## end if ( not defined $rule_resolution and ...) $rule_resolution //= $default_action_resolution; if ( not $rule_resolution ) { my $rule_desc = rule_describe($grammar, $rule_id); my $message = "Could not resolve action\n Rule was $rule_desc\n"; my $rule = $rules->[$rule_id]; my $action = $rule->[Marpa::R2::Internal::Rule::ACTION_NAME]; $message .= qq{ Action was specified as "$action"\n} if defined $action; my $recce_error = $recce->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE]; $message .= q{ } . $recce_error if defined $recce_error; Marpa::R2::exception($message); } ## end if ( not $rule_resolution ) DETERMINE_BLESSING: { my $blessing = Marpa::R2::Internal::Recognizer::rule_blessing_find( $recce, $rule_id ); my ( $closure_name, $closure, $semantics ) = @{$rule_resolution}; if ( $blessing ne '::undef' ) { $semantics = '::array' if $semantics eq '::!default'; CHECK_SEMANTICS: { last CHECK_SEMANTICS if $semantics eq '::array'; last CHECK_SEMANTICS if ( substr $semantics, 0, 1 ) eq '['; Marpa::R2::exception( qq{Attempt to bless, but improper semantics: "$semantics"} ); } ## end CHECK_SEMANTICS: } ## end if ( $blessing ne '::undef' ) $rule_resolution = [ $closure_name, $closure, $semantics, $blessing ]; } ## end DETERMINE_BLESSING: $rule_resolutions->[$rule_id] = $rule_resolution; } ## end RULE: for my $rule_id ( $grammar->rule_ids() ) if ( $trace_actions >= 2 ) { RULE: for my $rule_id ( 0 .. $#{$rules} ) { my ( $resolution_name, $closure ) = @{ $rule_resolutions->[$rule_id] }; say {$trace_file_handle} 'Rule ', $grammar->brief_rule($rule_id), qq{ resolves to "$resolution_name"} or Marpa::R2::exception('print to trace handle failed'); } ## end RULE: for my $rule_id ( 0 .. $#{$rules} ) } ## end if ( $trace_actions >= 2 ) my @lexeme_resolutions = (); SYMBOL: for my $lexeme_id ( 0 .. $#{$symbols} ) { my $semantics = Marpa::R2::Internal::Recognizer::lexeme_semantics_find( $recce, $lexeme_id ); if ( not defined $semantics ) { my $message = "Could not determine lexeme's semantics\n" . q{ Lexeme was } . $grammar->symbol_name($lexeme_id) . "\n"; $message .= q{ } . $recce ->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE]; Marpa::R2::exception($message); } ## end if ( not defined $semantics ) my $blessing = Marpa::R2::Internal::Recognizer::lexeme_blessing_find( $recce, $lexeme_id ); if ( not defined $blessing ) { my $message = "Could not determine lexeme's blessing\n" . q{ Lexeme was } . $grammar->symbol_name($lexeme_id) . "\n"; $message .= q{ } . $recce ->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE]; Marpa::R2::exception($message); } ## end if ( not defined $blessing ) $lexeme_resolutions[$lexeme_id] = [ $semantics, $blessing ]; } ## end SYMBOL: for my $lexeme_id ( 0 .. $#{$symbols} ) return ($rule_resolutions, \@lexeme_resolutions); } sub registration_init { my ( $recce, $per_parse_arg ) = @_; my $trace_file_handle = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $trace_actions = $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my @closure_by_rule_id = (); my @semantics_by_rule_id = (); my @blessing_by_rule_id = (); my ($rule_resolutions, $lexeme_resolutions) = resolve_recce($recce, $per_parse_arg); # Set the arrays, and perform various checks on the resolutions # we received { # ::whatever is deprecated and has been removed from the docs # it is now equivalent to ::undef RULE: for my $rule_id ( $grammar->rule_ids() ) { my ( $new_resolution, $closure, $semantics, $blessing ) = @{ $rule_resolutions->[$rule_id] }; my $lhs_id = $grammar_c->rule_lhs($rule_id); REFINE_SEMANTICS: { if ('[' eq substr $semantics, 0, 1 and ']' eq substr $semantics, -1, 1 ) { # Normalize array semantics $semantics =~ s/ //gxms; last REFINE_SEMANTICS; } ## end if ( '[' eq substr $semantics, 0, 1 and ']' eq ...) state $allowed_semantics = { map { ; ( $_, 1 ) } qw(::array ::undef ::first ::whatever ::!default), q{} }; last REFINE_SEMANTICS if $allowed_semantics->{$semantics}; last REFINE_SEMANTICS if $semantics =~ m/ \A rhs \d+ \z /xms; Marpa::R2::exception( q{Unknown semantics for rule }, $grammar->brief_rule($rule_id), "\n", qq{ Semantics were specified as "$semantics"\n} ); } ## end REFINE_SEMANTICS: $semantics_by_rule_id[$rule_id] = $semantics; $blessing_by_rule_id[$rule_id] = $blessing; $closure_by_rule_id[$rule_id] = $closure; CHECK_BLESSING: { last CHECK_BLESSING if $blessing eq '::undef'; if ($closure) { my $ref_type = Scalar::Util::reftype $closure; if ( $ref_type eq 'SCALAR' ) { # The constant's dump might be long so I repeat the error message Marpa::R2::exception( qq{Fatal error: Attempt to bless a rule that resolves to a scalar constant\n}, qq{ Scalar constant is }, Data::Dumper::Dumper($closure), qq{ Blessing is "$blessing"\n}, q{ Rule is: }, $grammar->brief_rule($rule_id), "\n", qq{ Cannot bless rule when it resolves to a scalar constant}, "\n", ); } ## end if ( $ref_type eq 'SCALAR' ) last CHECK_BLESSING; } ## end if ($closure) last CHECK_BLESSING if $semantics eq '::array'; last CHECK_BLESSING if ( substr $semantics, 0, 1 ) eq '['; Marpa::R2::exception( qq{Cannot bless rule when the semantics are "$semantics"}, q{ Rule is: }, $grammar->brief_rule($rule_id), "\n", qq{ Blessing is "$blessing"\n}, qq{ Semantics are "$semantics"\n} ); } ## end CHECK_BLESSING: } ## end RULE: for my $rule_id ( $grammar->rule_ids() ) } ## end CHECK_FOR_WHATEVER_CONFLICT # A LHS can be nullable via more than one rule, # and that means more than one semantics might be specified for # the nullable symbol. This logic deals with that. my @nullable_rule_ids_by_lhs = (); RULE: for my $rule_id ( $grammar->rule_ids() ) { my $lhs_id = $grammar_c->rule_lhs($rule_id); push @{ $nullable_rule_ids_by_lhs[$lhs_id] }, $rule_id if $grammar_c->rule_is_nullable($rule_id); } my @null_symbol_closures; LHS: for ( my $lhs_id = 0; $lhs_id <= $#nullable_rule_ids_by_lhs; $lhs_id++ ) { my $rule_ids = $nullable_rule_ids_by_lhs[$lhs_id]; my $resolution_rule; # No nullable rules for this LHS? No problem. next LHS if not defined $rule_ids; my $rule_count = scalar @{$rule_ids}; # I am not sure if this test is necessary next LHS if $rule_count <= 0; # Just one nullable rule? Then that's our semantics. if ( $rule_count == 1 ) { $resolution_rule = $rule_ids->[0]; my ( $resolution_name, $closure ) = @{ $rule_resolutions->[$resolution_rule] }; if ($trace_actions) { my $lhs_name = $grammar->symbol_name($lhs_id); say {$trace_file_handle} qq{Nulled symbol "$lhs_name" }, qq{ resolved to "$resolution_name" from rule }, $grammar->brief_rule($resolution_rule) or Marpa::R2::exception('print to trace handle failed'); } ## end if ($trace_actions) $null_symbol_closures[$lhs_id] = $resolution_rule; next LHS; } ## end if ( $rule_count == 1 ) # More than one rule? Are any empty? # If so, use the semantics of the empty rule my @empty_rules = grep { $grammar_c->rule_length($_) <= 0 } @{$rule_ids}; if ( scalar @empty_rules ) { $resolution_rule = $empty_rules[0]; my ( $resolution_name, $closure ) = @{ $rule_resolutions->[$resolution_rule] }; if ($trace_actions) { my $lhs_name = $grammar->symbol_name($lhs_id); say {$trace_file_handle} qq{Nulled symbol "$lhs_name" }, qq{ resolved to "$resolution_name" from rule }, $grammar->brief_rule($resolution_rule) or Marpa::R2::exception('print to trace handle failed'); } ## end if ($trace_actions) $null_symbol_closures[$lhs_id] = $resolution_rule; next LHS; } ## end if ( scalar @empty_rules ) # Multiple rules, none of them empty. my ( $first_resolution, @other_resolutions ) = map { $rule_resolutions->[$_] } @{$rule_ids}; # Do they have more than one semantics? # If so, just call it an error and let the user sort it out. my ( $first_closure_name, undef, $first_semantics, $first_blessing ) = @{$first_resolution}; OTHER_RESOLUTION: for my $other_resolution (@other_resolutions) { my ( $other_closure_name, undef, $other_semantics, $other_blessing ) = @{$other_resolution}; if ($first_closure_name ne $other_closure_name or $first_semantics ne $other_semantics or $first_blessing ne $other_blessing) { Marpa::R2::exception( 'When nulled, symbol ', $grammar->symbol_name($lhs_id), qq{ can have more than one semantics\n}, qq{ Marpa needs there to be only one semantics\n}, qq{ The rules involved are:\n}, Marpa::R2::Internal::Recognizer::brief_rule_list( $recce, $rule_ids ) ); } } ## end OTHER_RESOLUTION: for my $other_resolution (@other_resolutions) # Multiple rules, but they all have one semantics. # So (obviously) use that semantics $resolution_rule = $rule_ids->[0]; my ( $resolution_name, $closure ) = @{ $rule_resolutions->[$resolution_rule] }; if ($trace_actions) { my $lhs_name = $grammar->symbol_name($lhs_id); say {$trace_file_handle} qq{Nulled symbol "$lhs_name" }, qq{ resolved to "$resolution_name" from rule }, $grammar->brief_rule($resolution_rule) or Marpa::R2::exception('print to trace handle failed'); } ## end if ($trace_actions) $null_symbol_closures[$lhs_id] = $resolution_rule; } ## end LHS: for ( my $lhs_id = 0; $lhs_id <= ...) # Do consistency checks # Set the object values $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES] = \@null_symbol_closures; my @semantics_by_lexeme_id = (); my @blessing_by_lexeme_id = (); # Check the lexeme semantics { # ::whatever is deprecated and has been removed from the docs # it is now equivalent to ::undef LEXEME: for my $lexeme_id ( 0 .. $#{$symbols} ) { my ( $semantics, $blessing ) = @{ $lexeme_resolutions->[$lexeme_id] }; CHECK_SEMANTICS: { if ( not $semantics ) { $semantics = '::!default'; last CHECK_SEMANTICS; } if ( ( substr $semantics, 0, 1 ) eq '[' ) { $semantics =~ s/ //gxms; last CHECK_SEMANTICS; } state $allowed_semantics = { map { ; ( $_, 1 ) } qw(::array ::undef ::!default ) }; if ( not $allowed_semantics->{$semantics} ) { Marpa::R2::exception( q{Unknown semantics for lexeme }, $grammar->symbol_name($lexeme_id), "\n", qq{ Semantics were specified as "$semantics"\n} ); } ## end if ( not $allowed_semantics->{$semantics} ) } ## end CHECK_SEMANTICS: CHECK_BLESSING: { if ( not $blessing ) { $blessing = '::undef'; last CHECK_BLESSING; } last CHECK_BLESSING if $blessing eq '::undef'; last CHECK_BLESSING if $blessing =~ /\A [[:alpha:]] [:\w]* \z /xms; Marpa::R2::exception( q{Unknown blessing for lexeme }, $grammar->symbol_name($lexeme_id), "\n", qq{ Blessing as specified as "$blessing"\n} ); } ## end CHECK_BLESSING: $semantics_by_lexeme_id[$lexeme_id] = $semantics; $blessing_by_lexeme_id[$lexeme_id] = $blessing; } ## end LEXEME: for my $lexeme_id ( 0 .. $#{$symbols} ) } my $null_values = $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES]; state $op_bless = Marpa::R2::Thin::op('bless'); state $op_callback = Marpa::R2::Thin::op('callback'); state $op_push_constant = Marpa::R2::Thin::op('push_constant'); state $op_push_length = Marpa::R2::Thin::op('push_length'); state $op_push_undef = Marpa::R2::Thin::op('push_undef'); state $op_push_one = Marpa::R2::Thin::op('push_one'); state $op_push_sequence = Marpa::R2::Thin::op('push_sequence'); state $op_push_start_location = Marpa::R2::Thin::op('push_start_location'); state $op_push_values = Marpa::R2::Thin::op('push_values'); state $op_result_is_array = Marpa::R2::Thin::op('result_is_array'); state $op_result_is_constant = Marpa::R2::Thin::op('result_is_constant'); state $op_result_is_n_of_sequence = Marpa::R2::Thin::op('result_is_n_of_sequence'); state $op_result_is_rhs_n = Marpa::R2::Thin::op('result_is_rhs_n'); state $op_result_is_token_value = Marpa::R2::Thin::op('result_is_token_value'); state $op_result_is_undef = Marpa::R2::Thin::op('result_is_undef'); my @nulling_symbol_by_semantic_rule; NULLING_SYMBOL: for my $nulling_symbol ( 0 .. $#{$null_values} ) { my $semantic_rule = $null_values->[$nulling_symbol]; next NULLING_SYMBOL if not defined $semantic_rule; $nulling_symbol_by_semantic_rule[$semantic_rule] = $nulling_symbol; } ## end NULLING_SYMBOL: for my $nulling_symbol ( 0 .. $#{$null_values} ) my @work_list = (); RULE: for my $rule_id ( $grammar->rule_ids() ) { my $semantics = $semantics_by_rule_id[$rule_id]; my $blessing = $blessing_by_rule_id[$rule_id]; $semantics = '::undef' if $semantics eq '::!default'; $semantics = '[values]' if $semantics eq '::array'; $semantics = '::undef' if $semantics eq '::whatever'; $semantics = '::rhs0' if $semantics eq '::first'; push @work_list, [ $rule_id, undef, $semantics, $blessing ]; } ## end RULE: for my $rule_id ( $grammar->rule_ids() ) RULE: for my $lexeme_id ( 0 .. $#{$symbols} ) { my $semantics = $semantics_by_lexeme_id[$lexeme_id]; my $blessing = $blessing_by_lexeme_id[$lexeme_id]; $semantics = '::value' if $semantics eq '::!default'; $semantics = '[value]' if $semantics eq '::array'; push @work_list, [ undef, $lexeme_id, $semantics, $blessing ]; } ## end RULE: for my $lexeme_id ( 0 .. $#{$symbols} ) # Registering operations is postponed to this point, because # the valuator must exist for this to happen. In the future, # it may be best to have a separate semantics object. my @nulling_closures = (); my @registrations = (); WORK_ITEM: for my $work_item (@work_list) { my ( $rule_id, $lexeme_id, $semantics, $blessing ) = @{$work_item}; my ( $closure, $rule, $rule_length, $is_sequence_rule, $is_discard_sequence_rule, $nulling_symbol_id ); if ( defined $rule_id ) { $nulling_symbol_id = $nulling_symbol_by_semantic_rule[$rule_id]; $closure = $closure_by_rule_id[$rule_id]; $rule = $rules->[$rule_id]; $rule_length = $grammar_c->rule_length($rule_id); $is_sequence_rule = defined $grammar_c->sequence_min($rule_id); $is_discard_sequence_rule = $is_sequence_rule && $rule->[Marpa::R2::Internal::Rule::DISCARD_SEPARATION]; } ## end if ( defined $rule_id ) # Determine the "fate" of the array of child values my $array_fate; ARRAY_FATE: { if ( defined $closure and ref $closure eq 'CODE' ) { $array_fate = $op_callback; last ARRAY_FATE; } if ( ( substr $semantics, 0, 1 ) eq '[' ) { $array_fate = $op_result_is_array; last ARRAY_FATE; } } ## end ARRAY_FATE: my @ops = (); SET_OPS: { if ( $semantics eq '::undef' ) { @ops = ($op_result_is_undef); last SET_OPS; } DO_CONSTANT: { last DO_CONSTANT if not defined $rule_id; my $thingy_ref = $closure_by_rule_id[$rule_id]; last DO_CONSTANT if not defined $thingy_ref; my $ref_type = Scalar::Util::reftype $thingy_ref; if ( $ref_type eq q{} ) { my $rule_desc = rule_describe($grammar, $rule_id); Marpa::R2::exception( qq{An action resolved to a scalar.\n}, qq{ This is not allowed.\n}, qq{ A constant action must be a reference.\n}, qq{ Rule was $rule_desc\n} ); } ## end if ( $ref_type eq q{} ) if ( $ref_type eq 'CODE' ) { # Set the nulling closure if this is the nulling symbol of a rule $nulling_closures[$nulling_symbol_id] = $thingy_ref if defined $nulling_symbol_id and defined $rule_id; last DO_CONSTANT; } ## end if ( $ref_type eq 'CODE' ) if ( $ref_type eq 'SCALAR' ) { my $thingy = ${$thingy_ref}; if ( not defined $thingy ) { @ops = ($op_result_is_undef); last SET_OPS; } @ops = ( $op_result_is_constant, $thingy_ref ); last SET_OPS; } ## end if ( $ref_type eq 'SCALAR' ) # No test for 'ARRAY' or 'HASH' -- # The ref is currenly only to scalar and code slots in the symbol table, # and therefore cannot be to (among other things) an ARRAY or HASH if ( $ref_type eq 'REF' ) { @ops = ( $op_result_is_constant, $thingy_ref ); last SET_OPS; } my $rule_desc = rule_describe($grammar, $rule_id); Marpa::R2::exception( qq{Constant action is not of an allowed type.\n}, qq{ It was of type reference to $ref_type.\n}, qq{ Rule was $rule_desc\n} ); } ## end DO_CONSTANT: # After this point, any closure will be a ref to 'CODE' if ( defined $lexeme_id and $semantics eq '::value' ) { @ops = ($op_result_is_token_value); last SET_OPS; } PROCESS_SINGLETON_RESULT: { last PROCESS_SINGLETON_RESULT if not defined $rule_id; my $singleton; if ( $semantics =~ m/\A [:][:] rhs (\d+) \z/xms ) { $singleton = $1 + 0; } last PROCESS_SINGLETON_RESULT if not defined $singleton; my $singleton_element = $singleton; if ($is_discard_sequence_rule) { @ops = ( $op_result_is_n_of_sequence, $singleton_element ); last SET_OPS; } ## end if ($is_discard_sequence_rule) if ($is_sequence_rule) { @ops = ( $op_result_is_rhs_n, $singleton_element ); last SET_OPS; } my $mask = $rule->[Marpa::R2::Internal::Rule::MASK]; my @elements = grep { $mask->[$_] } 0 .. ( $rule_length - 1 ); if ( not scalar @elements ) { my $original_semantics = $semantics_by_rule_id[$rule_id]; Marpa::R2::exception( q{Impossible semantics for empty rule: }, $grammar->brief_rule($rule_id), "\n", qq{ Semantics were specified as "$original_semantics"\n} ); } ## end if ( not scalar @elements ) $singleton_element = $elements[$singleton]; if ( not defined $singleton_element ) { my $original_semantics = $semantics_by_rule_id[$rule_id]; Marpa::R2::exception( q{Impossible semantics for rule: }, $grammar->brief_rule($rule_id), "\n", qq{ Semantics were specified as "$original_semantics"\n} ); } ## end if ( not defined $singleton_element ) @ops = ( $op_result_is_rhs_n, $singleton_element ); last SET_OPS; } ## end PROCESS_SINGLETON_RESULT: if ( not defined $array_fate ) { @ops = ($op_result_is_undef); last SET_OPS; } # if here, $array_fate is defined my @bless_ops = (); if ( $blessing ne '::undef' ) { push @bless_ops, $op_bless, \$blessing; } Marpa::R2::exception(qq{Unknown semantics: "$semantics"}) if ( substr $semantics, 0, 1 ) ne '['; my @push_ops = (); my $array_descriptor = substr $semantics, 1, -1; $array_descriptor =~ s/^\s*|\s*$//g; RESULT_DESCRIPTOR: for my $result_descriptor ( split /[,]\s*/xms, $array_descriptor ) { $result_descriptor =~ s/^\s*|\s*$//g; if ( $result_descriptor eq 'start' ) { push @push_ops, $op_push_start_location; next RESULT_DESCRIPTOR; } if ( $result_descriptor eq 'length' ) { push @push_ops, $op_push_length; next RESULT_DESCRIPTOR; } if ( $result_descriptor eq 'lhs' ) { if (defined $rule_id) { my $lhs_id = $grammar_c->rule_lhs($rule_id); push @push_ops, $op_push_constant, \$lhs_id; next RESULT_DESCRIPTOR; } if ( defined $lexeme_id ) { push @push_ops, $op_push_constant, \$lexeme_id; next RESULT_DESCRIPTOR; } push @push_ops, $op_push_undef; next RESULT_DESCRIPTOR; } if ( $result_descriptor eq 'name' ) { if (defined $rule_id) { my $name = $grammar->rule_name($rule_id); push @push_ops, $op_push_constant, \$name; next RESULT_DESCRIPTOR; } if ( defined $lexeme_id ) { my $name = $tracer->symbol_name($lexeme_id); push @push_ops, $op_push_constant, \$name; next RESULT_DESCRIPTOR; } if ( defined $nulling_symbol_id ) { my $name = $tracer->symbol_name($nulling_symbol_id); push @push_ops, $op_push_constant, \$name; next RESULT_DESCRIPTOR; } push @push_ops, $op_push_undef; next RESULT_DESCRIPTOR; } if ( $result_descriptor eq 'symbol' ) { if (defined $rule_id) { my $lhs_id = $grammar_c->rule_lhs($rule_id); my $name = $tracer->symbol_name($lhs_id); push @push_ops, $op_push_constant, \$name; next RESULT_DESCRIPTOR; } if ( defined $lexeme_id ) { my $name = $tracer->symbol_name($lexeme_id); push @push_ops, $op_push_constant, \$name; next RESULT_DESCRIPTOR; } if ( defined $nulling_symbol_id ) { my $name = $tracer->symbol_name($nulling_symbol_id); push @push_ops, $op_push_constant, \$name; next RESULT_DESCRIPTOR; } push @push_ops, $op_push_undef; next RESULT_DESCRIPTOR; } if ( $result_descriptor eq 'rule' ) { if (defined $rule_id) { push @push_ops, $op_push_constant, \$rule_id; next RESULT_DESCRIPTOR; } push @push_ops, $op_push_undef; next RESULT_DESCRIPTOR; } if ( $result_descriptor eq 'values' or $result_descriptor eq 'value' ) { if ( defined $lexeme_id ) { push @push_ops, $op_push_values; next RESULT_DESCRIPTOR; } if ($is_sequence_rule) { my $push_op = $is_discard_sequence_rule ? $op_push_sequence : $op_push_values; push @push_ops, $push_op; next RESULT_DESCRIPTOR; } ## end if ($is_sequence_rule) my $mask = $rule->[Marpa::R2::Internal::Rule::MASK]; if ( $rule_length > 0 ) { push @push_ops, map { $mask->[$_] ? ( $op_push_one, $_ ) : () } 0 .. $rule_length - 1; } ## end if ( $rule_length > 0 ) next RESULT_DESCRIPTOR; } ## end if ( $result_descriptor eq 'values' or ...) Marpa::R2::exception( qq{Unknown result descriptor: "$result_descriptor"\n}, qq{ The full semantics were "$semantics"} ); } ## end RESULT_DESCRIPTOR: for my $result_descriptor ( split /[,]/xms, ...) @ops = ( @push_ops, @bless_ops, $array_fate ); } ## end SET_OPS: if ( defined $rule_id ) { push @registrations, [ 'rule', $rule_id, @ops ]; } if ( defined $nulling_symbol_id ) { my $slr = $Marpa::R2::Context::slr; if ( defined $slr and $tracer->symbol_name($nulling_symbol_id) eq '[:start]' and defined( my $default_g1_start_closure = $slr->default_g1_start_closure() ) ) { # Special case for SLIF nulling start symbol when there is a default action $nulling_closures[$nulling_symbol_id] = $default_g1_start_closure; @ops = ($op_callback); } ## end if ( defined $slr and $tracer->symbol_name(...)) push @registrations, [ 'nulling', $nulling_symbol_id, @ops ]; } ## end if ( defined $nulling_symbol_id ) if ( defined $lexeme_id ) { push @registrations, [ 'token', $lexeme_id, @ops ]; } $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] = \@registrations; $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_SYMBOL_ID] = \@nulling_closures; $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_RULE_ID] = \@closure_by_rule_id; } ## end WORK_ITEM: for my $work_item (@work_list) } # Returns false if no parse sub Marpa::R2::Recognizer::value { my ( $recce, $slr, $per_parse_arg ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $trace_actions = $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0; my $trace_values = $recce->[Marpa::R2::Internal::Recognizer::TRACE_VALUES] // 0; my $trace_file_handle = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE]; local $Marpa::R2::Internal::TRACE_FH = $trace_file_handle; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $token_values = $recce->[Marpa::R2::Internal::Recognizer::TOKEN_VALUES]; if ( scalar @_ != 1 ) { Marpa::R2::exception( 'Too many arguments to Marpa::R2::Recognizer::value') if ref $slr ne 'Marpa::R2::Scanless::R'; } $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE] //= 'tree'; if ( $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE] ne 'tree' ) { Marpa::R2::exception( "value() called when recognizer is not in tree mode\n", ' The current mode is "', $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE], qq{"\n} ); } ## end if ( $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE...]) my $furthest_earleme = $recce_c->furthest_earleme(); my $last_completed_earleme = $recce_c->current_earleme(); Marpa::R2::exception( "Attempt to evaluate incompletely recognized parse:\n", " Last token ends at location $furthest_earleme\n", " Recognition done only as far as location $last_completed_earleme\n" ) if $furthest_earleme > $last_completed_earleme; my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C]; if ($tree) { # On second and later calls to value() in a parse series, we need # to check the per-parse arg CHECK_ARG: { my $package_source = $recce ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE]; last CHECK_ARG if $package_source eq 'semantics_package'; # Anything is OK if ( $package_source eq 'legacy' ) { if ( defined $per_parse_arg ) { Marpa::R2::exception( "value() called with an argument while incompatible options are in use.\n", " Often this means that the discouraged 'action_object' named argument was used,\n", " and that 'semantics_package' should be used instead.\n" ); } ## end if ( defined $per_parse_arg ) last CHECK_ARG; } ## end if ( $package_source eq 'legacy' ) # If here the resolve package source is 'arg' if ( not defined $per_parse_arg ) { Marpa::R2::exception( "No value() arg, whe one is required to resolve semantics.\n", " Once value() has been called with a argument whose blessing is used to\n", " find the parse's semantics closures, it must always be called with an arg\n", " that is blessed in the same package\n", q{ In this case, the package was "}, $recce ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE], qq{"\n"} ); } ## end if ( not defined $per_parse_arg ) my $arg_blessing = Scalar::Util::blessed $per_parse_arg; if ( not defined $arg_blessing ) { Marpa::R2::exception( "value() arg is not blessed when required for the semantics.\n", " Once value() has been called with a argument whose blessing is used to\n", " find the parse's semantics closures, it must always be called with an arg\n", " that is blessed in the same package\n", q{ In this case, the original package was "}, $recce ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE], qq{"\n"}, qq{ and the blessing in this call was "$arg_blessing"\n} ); } ## end if ( not defined $arg_blessing ) my $required_blessing = $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE]; if ( $arg_blessing ne $required_blessing ) { Marpa::R2::exception( "value() arg is blessed into the wrong package.\n", " Once value() has been called with a argument whose blessing is used to\n", " find the parse's semantics closures, it must always be called with an arg\n", " that is blessed in the same package\n", qq{ In this case, the original package was "$required_blessing" and \n}, qq{ and the blessing in this call was "$arg_blessing"\n} ); } ## end if ( $arg_blessing ne $required_blessing ) } ## end CHECK_ARG: # If we have a bocage, we are initialized if ( not $tree ) { # No tree means we are in ASF mode Marpa::R2::exception('value() called for recognizer in ASF mode'); } my $max_parses = $recce->[Marpa::R2::Internal::Recognizer::MAX_PARSES]; my $parse_count = $tree->parse_count(); if ( $max_parses and $parse_count > $max_parses ) { Marpa::R2::exception( "Maximum parse count ($max_parses) exceeded"); } } ## end if ($tree) else { # No tree, therefore not initialized $recce->ordering_create(); return if $recce->[Marpa::R2::Internal::Recognizer::NO_PARSE]; my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C]; $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C] = Marpa::R2::Thin::T->new($order); } ## end else [ if ($tree) ] if ( $recce->[Marpa::R2::Internal::Recognizer::TRACE_AND_NODES] ) { print {$trace_file_handle} 'AND_NODES: ', $recce->show_and_nodes() or Marpa::R2::exception('print to trace handle failed'); } if ( $recce->[Marpa::R2::Internal::Recognizer::TRACE_OR_NODES] ) { print {$trace_file_handle} 'OR_NODES: ', $recce->show_or_nodes() or Marpa::R2::exception('print to trace handle failed'); } if ( $recce->[Marpa::R2::Internal::Recognizer::TRACE_BOCAGE] ) { print {$trace_file_handle} 'BOCAGE: ', $recce->show_bocage() or Marpa::R2::exception('print to trace handle failed'); } return if not defined $tree->next(); local $Marpa::R2::Context::grammar = $grammar; local $Marpa::R2::Context::rule = undef; local $Marpa::R2::Context::slr = $slr; local $Marpa::R2::Context::slg = $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR] if defined $slr; if ( not $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] ) { registration_init( $recce, $per_parse_arg ); } ## end if ( not $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS...]) my $semantics_arg0; if ( my $per_parse_constructor = $recce->[Marpa::R2::Internal::Recognizer::PER_PARSE_CONSTRUCTOR] ) { my $constructor_arg0; if ( $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE] eq 'legacy' ) { $constructor_arg0 = $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT]; } ## end if ( $recce->[...]) else { $constructor_arg0 = $per_parse_arg // $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE]; } my @warnings; my $eval_ok; my $fatal_error; DO_EVAL: { local $EVAL_ERROR = undef; local $SIG{__WARN__} = sub { push @warnings, [ $_[0], ( caller 0 ) ]; }; $eval_ok = eval { $semantics_arg0 = $per_parse_constructor->($constructor_arg0); 1; }; $fatal_error = $EVAL_ERROR; } ## end DO_EVAL: if ( not $eval_ok or @warnings ) { code_problems( { fatal_error => $fatal_error, grammar => $grammar, eval_ok => $eval_ok, warnings => \@warnings, where => 'constructing action object', } ); } ## end if ( not $eval_ok or @warnings ) } ## end if ( my $per_parse_constructor = $recce->[...]) $semantics_arg0 //= $per_parse_arg // {}; my $value = Marpa::R2::Thin::V->new($tree); if ($slr) { $value->slr_set( $slr->thin() ); } else { $value->valued_force(); TOKEN_IX: for ( my $token_ix = 2; $token_ix <= $#{$token_values}; $token_ix++ ) { my $token_value = $token_values->[$token_ix]; $value->token_value_set( $token_ix, $token_value ) if defined $token_value; } ## end TOKEN_IX: for ( my $token_ix = 2; $token_ix <= $#{...}) } ## end else [ if ($slr) ] local $Marpa::R2::Internal::Context::VALUATOR = $value; value_trace( $value, $trace_values ? 1 : 0 ); $value->trace_values($trace_values); $value->stack_mode_set(); my $null_values = $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES]; my $nulling_closures = $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_SYMBOL_ID]; my $rule_closures = $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_RULE_ID]; REGISTRATION: for my $registration ( @{ $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] } ) { my ( $type, $id, @raw_ops ) = @{$registration}; my @ops = (); if ( $trace_values > 2 ) { say {$trace_file_handle} "Registering semantics for $type: ", $grammar->symbol_name($id), "\n", ' Semantics are ', show_semantics(@raw_ops) or Marpa::R2::exception('Cannot say to trace file handle'); } ## end if ( $trace_values > 2 ) OP: for my $raw_op (@raw_ops) { if ( ref $raw_op ) { push @ops, $value->constant_register( ${$raw_op} ); next OP; } push @ops, $raw_op; } ## end OP: for my $raw_op (@raw_ops) if ( $type eq 'token' ) { $value->token_register( $id, @ops ); next REGISTRATION; } if ( $type eq 'nulling' ) { $value->nulling_symbol_register( $id, @ops ); next REGISTRATION; } if ( $type eq 'rule' ) { $value->rule_register( $id, @ops ); next REGISTRATION; } Marpa::R2::exception( 'Registration: with unknown type: ', Data::Dumper::Dumper($registration) ); } ## end REGISTRATION: for my $registration ( @{ $recce->[...]}) STEP: while (1) { my ( $value_type, @value_data ) = $value->stack_step(); if ($trace_values) { EVENT: while (1) { my $event = $value->event(); last EVENT if not defined $event; my ( $event_type, @event_data ) = @{$event}; if ( $event_type eq 'MARPA_STEP_TOKEN' ) { my ( $token_id, $token_value_ix ) = @event_data; my $token_value = $token_values->[$token_value_ix]; trace_token_evaluation( $recce, $value, $token_id, $token_value ); next EVENT; } ## end if ( $event_type eq 'MARPA_STEP_TOKEN' ) say {$trace_file_handle} join q{ }, 'value event:', map { $_ // 'undef' } $event_type, @event_data or Marpa::R2::exception('say to trace handle failed'); } ## end EVENT: while (1) if ( $trace_values >= 9 ) { for my $i ( reverse 0 .. $value->highest_index ) { printf {$trace_file_handle} "Stack position %3d:\n", $i, or Marpa::R2::exception('print to trace handle failed'); print {$trace_file_handle} q{ }, Data::Dumper->new( [ \$value->absolute($i) ] ) ->Terse(1)->Dump or Marpa::R2::exception('print to trace handle failed'); } ## end for my $i ( reverse 0 .. $value->highest_index ) } ## end if ( $trace_values >= 9 ) } ## end if ($trace_values) last STEP if not defined $value_type; next STEP if $value_type eq 'trace'; if ( $value_type eq 'MARPA_STEP_NULLING_SYMBOL' ) { my ($token_id) = @value_data; my $value_ref = $nulling_closures->[$token_id]; my $result; my @warnings; my $eval_ok; DO_EVAL: { local $SIG{__WARN__} = sub { push @warnings, [ $_[0], ( caller 0 ) ]; }; $eval_ok = eval { local $Marpa::R2::Context::rule = $null_values->[$token_id]; $result = $value_ref->($semantics_arg0); 1; }; } ## end DO_EVAL: if ( not $eval_ok or @warnings ) { my $fatal_error = $EVAL_ERROR; code_problems( { fatal_error => $fatal_error, grammar => $grammar, eval_ok => $eval_ok, warnings => \@warnings, where => 'computing value', long_where => 'Computing value for null symbol: ' . $grammar->symbol_name($token_id), } ); } ## end if ( not $eval_ok or @warnings ) $value->result_set($result); trace_token_evaluation( $recce, $value, $token_id, \$result ) if $trace_values; next STEP; } ## end if ( $value_type eq 'MARPA_STEP_NULLING_SYMBOL' ) if ( $value_type eq 'MARPA_STEP_RULE' ) { my ( $rule_id, $values ) = @value_data; my $closure = $rule_closures->[$rule_id]; next STEP if not defined $closure; my $result; if ( ref $closure eq 'CODE' ) { my @warnings; my $eval_ok; DO_EVAL: { local $SIG{__WARN__} = sub { push @warnings, [ $_[0], ( caller 0 ) ]; }; local $Marpa::R2::Context::rule = $rule_id; if ( Scalar::Util::blessed($values) ) { $eval_ok = eval { $result = $closure->( $semantics_arg0, $values ); 1; }; last DO_EVAL; } ## end if ( Scalar::Util::blessed($values) ) $eval_ok = eval { $result = $closure->( $semantics_arg0, @{$values} ); 1; }; } ## end DO_EVAL: if ( not $eval_ok or @warnings ) { my $fatal_error = $EVAL_ERROR; code_problems( { fatal_error => $fatal_error, grammar => $grammar, eval_ok => $eval_ok, warnings => \@warnings, where => 'computing value', long_where => 'Computing value for rule: ' . $grammar->brief_rule($rule_id), } ); } ## end if ( not $eval_ok or @warnings ) } ## end if ( ref $closure eq 'CODE' ) else { $result = ${$closure}; } $value->result_set($result); if ($trace_values) { say {$trace_file_handle} trace_stack_1( $grammar, $recce, $value, $values, $rule_id ) or Marpa::R2::exception('Could not print to trace file'); print {$trace_file_handle} 'Calculated and pushed value: ', Data::Dumper->new( [$result] )->Terse(1)->Dump or Marpa::R2::exception('print to trace handle failed'); } ## end if ($trace_values) next STEP; } ## end if ( $value_type eq 'MARPA_STEP_RULE' ) if ( $value_type eq 'MARPA_STEP_TRACE' ) { if ( my $trace_output = trace_op( $grammar, $recce, $value ) ) { print {$trace_file_handle} $trace_output or Marpa::R2::exception('Could not print to trace file'); } next STEP; } ## end if ( $value_type eq 'MARPA_STEP_TRACE' ) die "Internal error: Unknown value type $value_type"; } ## end STEP: while (1) return \($value->absolute(0)); } ## end sub Marpa::R2::Recognizer::value sub do_high_rule_only { my ($recce) = @_; my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C]; $order->high_rank_only_set(1); $order->rank(); return 1; } ## end sub do_high_rule_only sub do_rank_by_rule { my ($recce) = @_; my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C]; # Rank by rule is the default, but just in case $order->high_rank_only_set(0); $order->rank(); return 1; } ## end sub do_rank_by_rule # INTERNAL OK AFTER HERE _marpa_ sub Marpa::R2::Recognizer::show_bocage { my ($recce) = @_; my @data = (); my $id = 0; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; OR_NODE: for ( my $or_node_id = 0;; $or_node_id++ ) { my $irl_id = $bocage->_marpa_b_or_node_irl($or_node_id); last OR_NODE if not defined $irl_id; my $position = $bocage->_marpa_b_or_node_position($or_node_id); my $or_origin = $bocage->_marpa_b_or_node_origin($or_node_id); my $origin_earleme = $recce_c->earleme($or_origin); my $or_set = $bocage->_marpa_b_or_node_set($or_node_id); my $current_earleme = $recce_c->earleme($or_set); my @and_node_ids = ( $bocage->_marpa_b_or_node_first_and($or_node_id) .. $bocage->_marpa_b_or_node_last_and($or_node_id) ); AND_NODE: for my $and_node_id (@and_node_ids) { my $symbol = $bocage->_marpa_b_and_node_symbol($and_node_id); my $cause_tag; if ( defined $symbol ) { $cause_tag = "S$symbol"; } my $cause_id = $bocage->_marpa_b_and_node_cause($and_node_id); my $cause_irl_id; if ( defined $cause_id ) { $cause_irl_id = $bocage->_marpa_b_or_node_irl($cause_id); $cause_tag = Marpa::R2::Recognizer::or_node_tag( $recce, $cause_id ); } my $parent_tag = Marpa::R2::Recognizer::or_node_tag( $recce, $or_node_id ); my $predecessor_id = $bocage->_marpa_b_and_node_predecessor($and_node_id); my $predecessor_tag = q{-}; if ( defined $predecessor_id ) { $predecessor_tag = Marpa::R2::Recognizer::or_node_tag( $recce, $predecessor_id ); } my $tag = join q{ }, "$and_node_id:", "$or_node_id=$parent_tag", $predecessor_tag, $cause_tag; push @data, [ $and_node_id, $tag ]; } ## end AND_NODE: for my $and_node_id (@and_node_ids) } ## end OR_NODE: for ( my $or_node_id = 0;; $or_node_id++ ) my @sorted_data = map { $_->[-1] } sort { $a->[0] <=> $b->[0] } @data; return ( join "\n", @sorted_data ) . "\n"; } ## end sub Marpa::R2::Recognizer::show_bocage sub Marpa::R2::Recognizer::and_node_tag { my ( $recce, $and_node_id ) = @_; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $parent_or_node_id = $bocage->_marpa_b_and_node_parent($and_node_id); my $origin = $bocage->_marpa_b_or_node_origin($parent_or_node_id); my $origin_earleme = $recce_c->earleme($origin); my $current_earley_set = $bocage->_marpa_b_or_node_set($parent_or_node_id); my $current_earleme = $recce_c->earleme($current_earley_set); my $cause_id = $bocage->_marpa_b_and_node_cause($and_node_id); my $predecessor_id = $bocage->_marpa_b_and_node_predecessor($and_node_id); my $middle_earley_set = $bocage->_marpa_b_and_node_middle($and_node_id); my $middle_earleme = $recce_c->earleme($middle_earley_set); my $position = $bocage->_marpa_b_or_node_position($parent_or_node_id); my $irl_id = $bocage->_marpa_b_or_node_irl($parent_or_node_id); #<<< perltidy introduces trailing space on this my $tag = 'R' . $irl_id . q{:} . $position . q{@} . $origin_earleme . q{-} . $current_earleme; #>>> if ( defined $cause_id ) { my $cause_irl_id = $bocage->_marpa_b_or_node_irl($cause_id); $tag .= 'C' . $cause_irl_id; } else { my $symbol = $bocage->_marpa_b_and_node_symbol($and_node_id); $tag .= 'S' . $symbol; } $tag .= q{@} . $middle_earleme; return $tag; } ## end sub Marpa::R2::Recognizer::and_node_tag sub Marpa::R2::Recognizer::show_and_nodes { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $text; my @data = (); AND_NODE: for ( my $id = 0;; $id++ ) { my $parent = $bocage->_marpa_b_and_node_parent($id); my $predecessor = $bocage->_marpa_b_and_node_predecessor($id); my $cause = $bocage->_marpa_b_and_node_cause($id); my $symbol = $bocage->_marpa_b_and_node_symbol($id); last AND_NODE if not defined $parent; my $origin = $bocage->_marpa_b_or_node_origin($parent); my $set = $bocage->_marpa_b_or_node_set($parent); my $irl_id = $bocage->_marpa_b_or_node_irl($parent); my $position = $bocage->_marpa_b_or_node_position($parent); my $origin_earleme = $recce_c->earleme($origin); my $current_earleme = $recce_c->earleme($set); my $middle_earley_set = $bocage->_marpa_b_and_node_middle($id); my $middle_earleme = $recce_c->earleme($middle_earley_set); #<<< perltidy introduces trailing space on this my $desc = "And-node #$id: R" . $irl_id . q{:} . $position . q{@} . $origin_earleme . q{-} . $current_earleme; #>>> my $cause_rule = -1; if ( defined $cause ) { my $cause_irl_id = $bocage->_marpa_b_or_node_irl($cause); $desc .= 'C' . $cause_irl_id; } else { $desc .= 'S' . $symbol; } $desc .= q{@} . $middle_earleme; push @data, [ $origin_earleme, $current_earleme, $irl_id, $position, $middle_earleme, $cause_rule, ( $symbol // -1 ), $desc ]; } ## end AND_NODE: for ( my $id = 0;; $id++ ) my @sorted_data = map { $_->[-1] } sort { $a->[0] <=> $b->[0] or $a->[1] <=> $b->[1] or $a->[2] <=> $b->[2] or $a->[3] <=> $b->[3] or $a->[4] <=> $b->[4] or $a->[5] <=> $b->[5] or $a->[6] <=> $b->[6] } @data; return ( join "\n", @sorted_data ) . "\n"; } ## end sub Marpa::R2::Recognizer::show_and_nodes sub Marpa::R2::Recognizer::or_node_tag { my ( $recce, $or_node_id ) = @_; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $set = $bocage->_marpa_b_or_node_set($or_node_id); my $irl_id = $bocage->_marpa_b_or_node_irl($or_node_id); my $origin = $bocage->_marpa_b_or_node_origin($or_node_id); my $position = $bocage->_marpa_b_or_node_position($or_node_id); return 'R' . $irl_id . q{:} . $position . q{@} . $origin . q{-} . $set; } ## end sub Marpa::R2::Recognizer::or_node_tag sub Marpa::R2::Recognizer::show_or_nodes { my ( $recce, $verbose ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $text; my @data = (); my $id = 0; OR_NODE: for ( ;; ) { my $origin = $bocage->_marpa_b_or_node_origin($id); my $set = $bocage->_marpa_b_or_node_set($id); my $irl_id = $bocage->_marpa_b_or_node_irl($id); my $position = $bocage->_marpa_b_or_node_position($id); $id++; last OR_NODE if not defined $origin; my $origin_earleme = $recce_c->earleme($origin); my $current_earleme = $recce_c->earleme($set); #<<< perltidy introduces trailing space on this my $desc = 'R' . $irl_id . q{:} . $position . q{@} . $origin_earleme . q{-} . $current_earleme; #>>> push @data, [ $origin_earleme, $current_earleme, $irl_id, $position, $desc ]; } ## end OR_NODE: for ( ;; ) my @sorted_data = map { $_->[-1] } sort { $a->[0] <=> $b->[0] or $a->[1] <=> $b->[1] or $a->[2] <=> $b->[2] or $a->[3] <=> $b->[3] } @data; return ( join "\n", @sorted_data ) . "\n"; } ## end sub Marpa::R2::Recognizer::show_or_nodes # Not sorted and therefore not suitable for test suite sub Marpa::R2::Recognizer::verbose_or_nodes { my ($recce) = @_; my $text = q{}; OR_NODE: for ( my $or_node_id = 0; defined( my $or_node_desc = $recce->verbose_or_node($or_node_id) ); $or_node_id++ ) { $text .= $or_node_desc; } ## end OR_NODE: for ( my $or_node_id = 0; defined( my $or_node_desc =...)) return $text; } ## end sub Marpa::R2::Recognizer::verbose_or_nodes sub Marpa::R2::Recognizer::verbose_or_node { my ( $recce, $or_node_id ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $origin = $bocage->_marpa_b_or_node_origin($or_node_id); return if not defined $origin; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $set = $bocage->_marpa_b_or_node_set($or_node_id); my $irl_id = $bocage->_marpa_b_or_node_irl($or_node_id); my $position = $bocage->_marpa_b_or_node_position($or_node_id); my $origin_earleme = $recce_c->earleme($origin); my $current_earleme = $recce_c->earleme($set); my $text = "OR-node #$or_node_id: R$irl_id" . q{:} . $position . q{@} . $origin_earleme . q{-} . $current_earleme . "\n"; $text .= ( q{ } x 4 ) . $tracer->show_dotted_irl( $irl_id, $position ) . "\n"; return $text; } ## end sub Marpa::R2::Recognizer::verbose_or_node sub Marpa::R2::Recognizer::show_nook { my ( $recce, $nook_id, $verbose ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C]; my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C]; my $or_node_id = $tree->_marpa_t_nook_or_node($nook_id); return if not defined $or_node_id; my $text = "o$or_node_id"; my $parent = $tree->_marpa_t_nook_parent($nook_id) // q{-}; CHILD_TYPE: { if ( $tree->_marpa_t_nook_is_cause($nook_id) ) { $text .= "[c$parent]"; last CHILD_TYPE; } if ( $tree->_marpa_t_nook_is_predecessor($nook_id) ) { $text .= "[p$parent]"; last CHILD_TYPE; } $text .= '[-]'; } ## end CHILD_TYPE: my $or_node_tag = Marpa::R2::Recognizer::or_node_tag( $recce, $or_node_id ); $text .= " $or_node_tag"; $text .= ' p'; $text .= $tree->_marpa_t_nook_predecessor_is_ready($nook_id) ? q{=ok} : q{-}; $text .= ' c'; $text .= $tree->_marpa_t_nook_cause_is_ready($nook_id) ? q{=ok} : q{-}; $text .= "\n"; DESCRIBE_CHOICES: { my $this_choice = $tree->_marpa_t_nook_choice($nook_id); CHOICE: for ( my $choice_ix = 0;; $choice_ix++ ) { my $and_node_id = $order->_marpa_o_and_node_order_get( $or_node_id, $choice_ix ); last CHOICE if not defined $and_node_id; $text .= " o$or_node_id" . '[' . $choice_ix . ']'; if ( defined $this_choice and $this_choice == $choice_ix ) { $text .= q{*}; } my $and_node_tag = Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ); $text .= " ::= a$and_node_id $and_node_tag"; $text .= "\n"; } ## end CHOICE: for ( my $choice_ix = 0;; $choice_ix++ ) } ## end DESCRIBE_CHOICES: return $text; } ## end sub Marpa::R2::Recognizer::show_nook sub Marpa::R2::Recognizer::show_tree { my ( $recce, $verbose ) = @_; my $text = q{}; NOOK: for ( my $nook_id = 0; 1; $nook_id++ ) { my $nook_text = $recce->show_nook( $nook_id, $verbose ); last NOOK if not defined $nook_text; $text .= "$nook_id: $nook_text"; } return $text; } ## end sub Marpa::R2::Recognizer::show_tree sub trace_token_evaluation { my ( $recce, $value, $token_id, $token_value ) = @_; my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C]; my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $nook_ix = $value->_marpa_v_nook(); if ( not defined $nook_ix ) { print {$Marpa::R2::Internal::TRACE_FH} "Nulling valuator\n" or Marpa::R2::exception('Could not print to trace file'); return; } my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix); my $choice = $tree->_marpa_t_nook_choice($nook_ix); my $and_node_id = $order->_marpa_o_and_node_order_get( $or_node_id, $choice ); my $token_name; if ( defined $token_id ) { $token_name = $grammar->symbol_name($token_id); } print {$Marpa::R2::Internal::TRACE_FH} 'Pushed value from ', Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ), ': ', ( $token_name ? qq{$token_name = } : q{} ), Data::Dumper->new( [ \$token_value ] )->Terse(1)->Dump or Marpa::R2::exception('print to trace handle failed'); return; } ## end sub trace_token_evaluation sub trace_stack_1 { my ( $grammar, $recce, $value, $args, $rule_id ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C]; my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C]; my $argc = scalar @{$args}; my $nook_ix = $value->_marpa_v_nook(); my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix); my $choice = $tree->_marpa_t_nook_choice($nook_ix); my $and_node_id = $order->_marpa_o_and_node_order_get( $or_node_id, $choice ); return 'Popping ', $argc, ' values to evaluate ', Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ), ', rule: ', $grammar->brief_rule($rule_id); } ## end sub trace_stack_1 sub trace_op { my ( $grammar, $recce, $value ) = @_; my $trace_output = q{}; my $trace_values = $recce->[Marpa::R2::Internal::Recognizer::TRACE_VALUES] // 0; return $trace_output if not $trace_values >= 2; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C]; my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C]; my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C]; my $nook_ix = $value->_marpa_v_nook(); my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix); my $choice = $tree->_marpa_t_nook_choice($nook_ix); my $and_node_id = $order->_marpa_o_and_node_order_get( $or_node_id, $choice ); my $trace_irl_id = $bocage->_marpa_b_or_node_irl($or_node_id); my $virtual_rhs = $grammar_c->_marpa_g_irl_is_virtual_rhs($trace_irl_id); my $virtual_lhs = $grammar_c->_marpa_g_irl_is_virtual_lhs($trace_irl_id); return $trace_output if $bocage->_marpa_b_or_node_position($or_node_id) != $grammar_c->_marpa_g_irl_length($trace_irl_id); return $trace_output if not $virtual_rhs and not $virtual_lhs; if ( $virtual_rhs and not $virtual_lhs ) { $trace_output .= join q{}, 'Head of Virtual Rule: ', Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ), ', rule: ', $grammar->brief_irl($trace_irl_id), "\n", 'Incrementing virtual rule by ', $grammar_c->_marpa_g_real_symbol_count($trace_irl_id), ' symbols', "\n" or Marpa::R2::exception('Could not print to trace file'); return $trace_output; } ## end if ( $virtual_rhs and not $virtual_lhs ) if ( $virtual_lhs and $virtual_rhs ) { $trace_output .= join q{}, 'Virtual Rule: ', Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ), ', rule: ', $grammar->brief_irl($trace_irl_id), "\nAdding ", $grammar_c->_marpa_g_real_symbol_count($trace_irl_id), "\n"; return $trace_output; } ## end if ( $virtual_lhs and $virtual_rhs ) if ( not $virtual_rhs and $virtual_lhs ) { $trace_output .= join q{}, 'New Virtual Rule: ', Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ), ', rule: ', $grammar->brief_irl($trace_irl_id), "\nReal symbol count is ", $grammar_c->_marpa_g_real_symbol_count($trace_irl_id), "\n"; return $trace_output; } ## end if ( not $virtual_rhs and $virtual_lhs ) return $trace_output; } ## end sub trace_op sub value_trace { my ( $value, $trace_flag ) = @_; return $value->_marpa_v_trace($trace_flag); } 1; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/MetaAST.pm0000444000000000000000000017277012342464707016744 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::MetaAST; use 5.010; use strict; use warnings; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic(BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic package Marpa::R2::Internal::MetaAST; use English qw( -no_match_vars ); sub new { my ( $class, $p_rules_source ) = @_; my $meta_recce = Marpa::R2::Internal::Scanless::meta_recce(); eval { $meta_recce->read($p_rules_source) } or Marpa::R2::exception("Parse of BNF/Scanless source failed\n", $EVAL_ERROR); if ( $meta_recce->ambiguity_metric() > 1 ) { my $asf = Marpa::R2::ASF->new( { slr => $meta_recce } ); say STDERR 'No ASF' if not defined $asf; my $ambiguities = Marpa::R2::Internal::ASF::ambiguities( $asf ); my @ambiguities = grep { defined } @{$ambiguities}[0 .. 1 ]; Marpa::R2::exception( "Parse of BNF/Scanless source is ambiguous\n", Marpa::R2::Internal::ASF::ambiguities_show( $asf, \@ambiguities ) ); } my $value_ref = $meta_recce->value(); Marpa::R2::exception('Parse of BNF/Scanless source failed') if not defined $value_ref; my $ast = { meta_recce => $meta_recce, top_node => ${$value_ref} }; return bless $ast, $class; } ## end sub new sub Marpa::R2::Internal::MetaAST::Parse::substring { my ( $parse, $start, $length ) = @_; my $meta_slr = $parse->{meta_recce}; my $thin_meta_slr = $meta_slr->[Marpa::R2::Internal::Scanless::R::C]; my $string = $thin_meta_slr->substring( $start, $length ); chomp $string; return $string; } ## end sub Marpa::R2::Internal::MetaAST::Parse::substring sub ast_to_hash { my ($ast) = @_; my $hashed_ast = {}; $hashed_ast->{meta_recce} = $ast->{meta_recce}; bless $hashed_ast, 'Marpa::R2::Internal::MetaAST::Parse'; $hashed_ast->{current_lexer} = 'L0'; $hashed_ast->{rules}->{G1} = []; my $g1_symbols = $hashed_ast->{symbols}->{G1} = {}; my ( undef, undef, @statements ) = @{ $ast->{top_node} }; # This is the last ditch exception catcher # It forces all Marpa exceptions to be die's, # then catches them and rethrows using Carp. # # The plan is to use die(), with higher levels # catching and re-die()'ing after adding # helpful location information. After the # re-throw it is caught here and passed to # Carp. my $eval_ok = eval { local $Marpa::R2::JUST_DIE = 1; $_->evaluate($hashed_ast) for @statements; 1; }; Marpa::R2::exception($EVAL_ERROR) if not $eval_ok; my %grammars = (); $grammars{$_} = 1 for keys %{ $hashed_ast->{rules} }; my @lexers = grep { ( substr $_, 0, 1 ) eq 'L' } keys %grammars; for my $lexer (@lexers) { my $lexer_name = $lexer; NAME_LEXER: { if ( $lexer eq 'L0' ) { $lexer_name = "L0 (the default)"; last NAME_LEXER; } last NAME_LEXER if ( substr $lexer_name, 0, 2 ) ne 'L-'; $lexer_name = substr $lexer_name, 2; } ## end NAME_LEXER: } ## end for my $lexer (@lexers) my %stripped_character_classes = (); { my $character_classes = $hashed_ast->{character_classes}; for my $symbol_name ( sort keys %{$character_classes} ) { my ($re) = @{ $character_classes->{$symbol_name} }; $stripped_character_classes{$symbol_name} = $re; } } $hashed_ast->{character_classes} = \%stripped_character_classes; return $hashed_ast; } ## end sub ast_to_hash sub Marpa::R2::Internal::MetaAST::Parse::start_rule_setup { my ($ast) = @_; my $start_lhs = $ast->{'start_lhs'} // $ast->{'first_lhs'}; Marpa::R2::exception('No rules in SLIF grammar') if not defined $start_lhs; Marpa::R2::Internal::MetaAST::start_rule_create( $ast, $start_lhs ); } ## end sub Marpa::R2::Internal::MetaAST::Parse::start_rule_setup # This class is for pieces of RHS alternatives, as they are # being constructed my $PROTO_ALTERNATIVE = 'Marpa::R2::Internal::MetaAST::Proto_Alternative'; sub Marpa::R2::Internal::MetaAST::Proto_Alternative::combine { my ( $class, @hashes ) = @_; my $self = bless {}, $class; for my $hash_to_add (@hashes) { for my $key ( keys %{$hash_to_add} ) { ## expect to be caught and rethrown die qq{A Marpa rule contained a duplicate key\n}, qq{ The key was "$key"\n} if exists $self->{$key}; $self->{$key} = $hash_to_add->{$key}; } ## end for my $key ( keys %{$hash_to_add} ) } ## end for my $hash_to_add (@hashes) return $self; } ## end sub Marpa::R2::Internal::MetaAST::Proto_Alternative::combine sub Marpa::R2::Internal::MetaAST::Parse::bless_hash_rule { my ( $parse, $hash_rule, $blessing, $naming, $original_lhs ) = @_; return if (substr $Marpa::R2::Internal::SUBGRAMMAR, 0, 1) eq 'L'; $naming //= $original_lhs; $hash_rule->{name} = $naming; return if not defined $blessing; FIND_BLESSING: { last FIND_BLESSING if $blessing =~ /\A [\w] /xms; return if $blessing eq '::undef'; # Rule may be half-formed, but assume we have lhs if ( $blessing eq '::lhs' ) { $blessing = $original_lhs; if ( $blessing =~ / [^ [:alnum:]] /xms ) { Marpa::R2::exception( qq{"::lhs" blessing only allowed if LHS is whitespace and alphanumerics\n}, qq{ LHS was <$original_lhs>\n} ); } ## end if ( $blessing =~ / [^ [:alnum:]] /xms ) $blessing =~ s/[ ]/_/gxms; last FIND_BLESSING; } ## end if ( $blessing eq '::lhs' ) Marpa::R2::exception( qq{Unknown blessing "$blessing"\n} ); } ## end FIND_BLESSING: $hash_rule->{bless} = $blessing; return 1; } ## end sub Marpa::R2::Internal::MetaAST::Parse::bless_hash_rule sub Marpa::R2::Internal::MetaAST_Nodes::bare_name::name { return $_[0]->[2] } sub Marpa::R2::Internal::MetaAST_Nodes::reserved_action_name::name { my ( $self, $parse ) = @_; return $self->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::action_name::name { my ( $self, $parse ) = @_; return $self->[2]->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::alternative_name::name { my ( $self, $parse ) = @_; return $self->[2]->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::event_name::name { my ( $self, $parse ) = @_; return $self->[2]->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::lexer_name::name { my ( $self, $parse ) = @_; return $self->[2]->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::array_descriptor::name { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::reserved_blessing_name::name { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::blessing_name::name { my ( $self, $parse ) = @_; return $self->[2]->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::standard_name::name { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::Perl_name::name { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::lhs::name { my ( $values, $parse ) = @_; my ( undef, undef, $symbol ) = @{$values}; return $symbol->name($parse); } # After development, delete this sub Marpa::R2::Internal::MetaAST_Nodes::lhs::evaluate { my ( $values, $parse ) = @_; return $values->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::quantifier::evaluate { my ($data) = @_; return $data->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::op_declare::op { my ($values) = @_; return $values->[2]->op(); } sub Marpa::R2::Internal::MetaAST_Nodes::op_declare_match::op { my ($values) = @_; return $values->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::op_declare_bnf::op { my ($values) = @_; return $values->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::bracketed_name::name { my ($values) = @_; my ( undef, undef, $bracketed_name ) = @{$values}; # normalize whitespace $bracketed_name =~ s/\A [<] \s*//xms; $bracketed_name =~ s/ \s* [>] \z//xms; $bracketed_name =~ s/ \s+ / /gxms; return $bracketed_name; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::bracketed_name::name sub Marpa::R2::Internal::MetaAST_Nodes::single_quoted_name::name { my ($values) = @_; my ( undef, undef, $single_quoted_name ) = @{$values}; # normalize whitespace $single_quoted_name =~ s/\A ['] \s*//xms; $single_quoted_name =~ s/ \s* ['] \z//xms; $single_quoted_name =~ s/ \s+ / /gxms; return $single_quoted_name; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::single_quoted_name::name sub Marpa::R2::Internal::MetaAST_Nodes::parenthesized_rhs_primary_list::evaluate { my ( $data, $parse ) = @_; my ( undef, undef, @values ) = @{$data}; my @symbol_lists = map { $_->evaluate($parse); } @values; my $flattened_list = Marpa::R2::Internal::MetaAST::Symbol_List->combine(@symbol_lists); $flattened_list->mask_set(0); return $flattened_list; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::parenthesized_rhs_primary_list::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::rhs::evaluate { my ( $data, $parse ) = @_; my ( $start, $length, @values ) = @{$data}; my $rhs = eval { my @symbol_lists = map { $_->evaluate($parse) } @values; my $flattened_list = Marpa::R2::Internal::MetaAST::Symbol_List->combine(@symbol_lists); bless { rhs => $flattened_list->names($parse), mask => $flattened_list->mask() }, $PROTO_ALTERNATIVE; }; if ( not $rhs ) { my $eval_error = $EVAL_ERROR; chomp $eval_error; Marpa::R2::exception( qq{$eval_error\n}, q{ RHS involved was }, $parse->substring( $start, $length ) ); } ## end if ( not $rhs ) return $rhs; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::rhs::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::rhs_primary::evaluate { my ( $data, $parse ) = @_; my ( undef, undef, @values ) = @{$data}; my @symbol_lists = map { $_->evaluate($parse) } @values; return Marpa::R2::Internal::MetaAST::Symbol_List->combine(@symbol_lists); } ## end sub Marpa::R2::Internal::MetaAST_Nodes::rhs_primary::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::rhs_primary_list::evaluate { my ( $data, $parse ) = @_; my ( undef, undef, @values ) = @{$data}; my @symbol_lists = map { $_->evaluate($parse) } @values; return Marpa::R2::Internal::MetaAST::Symbol_List->combine(@symbol_lists); } ## end sub Marpa::R2::Internal::MetaAST_Nodes::rhs_primary_list::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::action::evaluate { my ( $values, $parse ) = @_; my ( undef, undef, $child ) = @{$values}; return bless { action => $child->name($parse) }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::blessing::evaluate { my ( $values, $parse ) = @_; my ( undef, undef, $child ) = @{$values}; return bless { bless => $child->name($parse) }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::naming::evaluate { my ( $values, $parse ) = @_; my ( undef, undef, $child ) = @{$values}; return bless { name => $child->name($parse) }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::right_association::evaluate { my ($values) = @_; return bless { assoc => 'R' }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::left_association::evaluate { my ($values) = @_; return bless { assoc => 'L' }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::group_association::evaluate { my ($values) = @_; return bless { assoc => 'G' }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::event_specification::evaluate { my ($values) = @_; my $child = $values->[2]; return bless { event => $child->name() }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::proper_specification::evaluate { my ($values) = @_; my $child = $values->[2]; return bless { proper => $child->value() }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::latm_specification::evaluate { my ($values) = @_; my $child = $values->[2]; return bless { latm => $child->value() }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::pause_specification::evaluate { my ($values) = @_; my $child = $values->[2]; return bless { pause => $child->value() }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::priority_specification::evaluate { my ($values) = @_; my $child = $values->[2]; return bless { priority => $child->value() }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::rank_specification::evaluate { my ($values) = @_; my $child = $values->[2]; return bless { rank => $child->value() }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::null_ranking_specification::evaluate { my ($values) = @_; my $child = $values->[2]; return bless { null_ranking => $child->value() }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::null_ranking_constant::value { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::before_or_after::value { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::boolean::value { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::signed_integer::value { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::separator_specification::evaluate { my ( $values, $parse ) = @_; my $child = $values->[2]; return bless { separator => $child->name($parse) }, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::adverb_item::evaluate { my ( $values, $parse ) = @_; my $child = $values->[2]->evaluate($parse); return bless $child, $PROTO_ALTERNATIVE; } sub Marpa::R2::Internal::MetaAST_Nodes::default_rule::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, undef, $op_declare, $raw_adverb_list ) = @{$values}; my $subgrammar = $op_declare->op() eq q{::=} ? 'G1' : $parse->{current_lexer}; my $adverb_list = $raw_adverb_list->evaluate($parse); # A default rule clears the previous default my %default_adverbs = (); $parse->{default_adverbs}->{$subgrammar} = \%default_adverbs; ADVERB: for my $key ( keys %{$adverb_list} ) { my $value = $adverb_list->{$key}; if ( $key eq 'action' and $subgrammar eq 'G1' ) { $default_adverbs{$key} = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'bless' and $subgrammar eq 'G1' ) { $default_adverbs{$key} = $adverb_list->{$key}; next ADVERB; } die qq{Adverb "$key" not allowed in $subgrammar default rule\n}, ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end ADVERB: for my $key ( keys %{$adverb_list} ) ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::default_rule::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::lexeme_default_statement::evaluate { my ( $data, $parse ) = @_; my ( $start, $length, $raw_adverb_list ) = @{$data}; local $Marpa::R2::Internal::SUBGRAMMAR = 'G1'; my $adverb_list = $raw_adverb_list->evaluate($parse); if ( exists $parse->{lexeme_default_adverbs} ) { my $problem_rule = $parse->substring( $start, $length ); Marpa::R2::exception( qq{More than one lexeme default statement is not allowed\n}, qq{ This was the rule that caused the problem:\n}, qq{ $problem_rule\n} ); } ## end if ( exists $parse->{lexeme_default_adverbs} ) $parse->{lexeme_default_adverbs} = {}; ADVERB: for my $key ( keys %{$adverb_list} ) { my $value = $adverb_list->{$key}; if ( $key eq 'action' ) { $parse->{lexeme_default_adverbs}->{$key} = $value; next ADVERB; } if ( $key eq 'bless' ) { $parse->{lexeme_default_adverbs}->{$key} = $value; next ADVERB; } if ( $key eq 'latm' ) { $parse->{lexeme_default_adverbs}->{$key} = $value; next ADVERB; } Marpa::R2::exception( qq{"$key" adverb not allowed as lexeme default"}); } ## end ADVERB: for my $key ( keys %{$adverb_list} ) ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::lexeme_default_statement::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::inaccessible_statement::evaluate { my ( $data, $parse ) = @_; my ( $start, $length, $inaccessible_treatment ) = @{$data}; local $Marpa::R2::Internal::SUBGRAMMAR = 'G1'; if ( exists $parse->{defaults}->{if_inaccessible} ) { my $problem_rule = $parse->substring( $start, $length ); Marpa::R2::exception( qq{More than one inaccessible default statement is not allowed\n}, qq{ This was the rule that caused the problem:\n}, qq{ $problem_rule\n} ); } $parse->{defaults}->{if_inaccessible} = $inaccessible_treatment->value(); return undef; } sub Marpa::R2::Internal::MetaAST_Nodes::inaccessible_treatment::value { return $_[0]->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::priority_rule::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $raw_lhs, $op_declare, $raw_priorities ) = @{$values}; my $current_lexer = $parse->{current_lexer}; my $subgrammar; if ( $op_declare->op() eq q{::=} ) { if ( $current_lexer ne 'L0' ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die "G1 rules currently allowed only when L0 is current lexer\n", qq{ A prioritized rule was found when "$current_lexer" was the current lexer\n"}, " Location was line $line, column $column\n", ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end if ( $current_lexer ne 'L0' ) $subgrammar = 'G1'; } ## end if ( $op_declare->op() eq q{::=} ) else { $subgrammar = $current_lexer; } my $lhs = $raw_lhs->name($parse); $parse->{'first_lhs'} //= $lhs if $subgrammar eq 'G1'; local $Marpa::R2::Internal::SUBGRAMMAR = $subgrammar; my ( undef, undef, @priorities ) = @{$raw_priorities}; my $priority_count = scalar @priorities; my @working_rules = (); $parse->{rules}->{$subgrammar} //= []; my $rules = $parse->{rules}->{$subgrammar}; my $default_adverbs = $parse->{default_adverbs}->{$subgrammar}; if ( $priority_count <= 1 ) { ## If there is only one priority my ( undef, undef, @alternatives ) = @{ $priorities[0] }; for my $alternative (@alternatives) { my ($alternative_start, $alternative_end, $raw_rhs, $raw_adverb_list ) = @{$alternative}; my ( $proto_rule, $adverb_list ); my $eval_ok = eval { $proto_rule = $raw_rhs->evaluate($parse); $adverb_list = $raw_adverb_list->evaluate($parse); 1; }; if ( not $eval_ok ) { my $eval_error = $EVAL_ERROR; chomp $eval_error; Marpa::R2::exception( qq{$eval_error\n}, qq{ The problem was in this RHS alternative:\n}, q{ }, $parse->substring( $alternative_start, $alternative_end ), "\n" ); } ## end if ( not $eval_ok ) my @rhs_names = @{ $proto_rule->{rhs} }; my @mask = @{ $proto_rule->{mask} }; if ( ( substr $subgrammar, 0, 1 ) eq 'L' and grep { !$_ } @mask ) { Marpa::R2::exception( qq{hidden symbols are not allowed in lexical rules (rules LHS was "$lhs")} ); } my %hash_rule = ( lhs => $lhs, rhs => \@rhs_names, mask => \@mask ); my $action; my $blessing; my $naming; my $null_ranking; my $rank; ADVERB: for my $key ( keys %{$adverb_list} ) { my $value = $adverb_list->{$key}; if ( $key eq 'action' ) { $action = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'assoc' ) { # OK, but ignored next ADVERB; } if ( $key eq 'bless' ) { $blessing = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'name' ) { $naming = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'null_ranking' ) { $null_ranking = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'rank' ) { $rank = $adverb_list->{$key}; next ADVERB; } my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{Adverb "$key" not allowed in an prioritized rule\n}, ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end ADVERB: for my $key ( keys %{$adverb_list} ) $action //= $default_adverbs->{action}; if ( defined $action ) { Marpa::R2::exception( 'actions not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $hash_rule{action} = $action; } ## end if ( defined $action ) $rank //= $default_adverbs->{rank}; if ( defined $rank ) { Marpa::R2::exception( 'ranks not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $hash_rule{rank} = $rank; } ## end if ( defined $rank ) $null_ranking //= $default_adverbs->{null_ranking}; if ( defined $null_ranking ) { Marpa::R2::exception( 'null-ranking allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $hash_rule{null_ranking} = $null_ranking; } ## end if ( defined $rank ) $blessing //= $default_adverbs->{bless}; if (defined $blessing and ( substr $subgrammar, 0, 1 ) eq 'L' ) { Marpa::R2::exception( 'bless option not allowed in lexical rules (rules LHS was "', $lhs, '")' ); } $parse->bless_hash_rule( \%hash_rule, $blessing, $naming, $lhs ); push @{$rules}, \%hash_rule; } ## end for my $alternative (@alternatives) ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end if ( $priority_count <= 1 ) for my $priority_ix ( 0 .. $priority_count - 1 ) { my $priority = $priority_count - ( $priority_ix + 1 ); my ( undef, undef, @alternatives ) = @{ $priorities[$priority_ix] }; for my $alternative (@alternatives) { my ($alternative_start, $alternative_end, $raw_rhs, $raw_adverb_list ) = @{$alternative}; my ( $adverb_list, $rhs ); my $eval_ok = eval { $adverb_list = $raw_adverb_list->evaluate($parse); $rhs = $raw_rhs->evaluate($parse); 1; }; if ( not $eval_ok ) { my $eval_error = $EVAL_ERROR; chomp $eval_error; Marpa::R2::exception( qq{$eval_error\n}, qq{ The problem was in this RHS alternative:\n}, q{ }, $parse->substring( $alternative_start, $alternative_end ), "\n" ); } ## end if ( not $eval_ok ) push @working_rules, [ $priority, $rhs, $adverb_list ]; } ## end for my $alternative (@alternatives) } ## end for my $priority_ix ( 0 .. $priority_count - 1 ) # Default mask (all ones) is OK for this rule my @arg0_action = (); @arg0_action = ( action => '::first' ) if $subgrammar eq 'G1'; push @{$rules}, { lhs => $lhs, rhs => [ $parse->prioritized_symbol( $lhs, 0 ) ], @arg0_action, description => qq{Internal rule top priority rule for <$lhs>}, }, ( map { ; { lhs => $parse->prioritized_symbol( $lhs, $_ - 1 ), rhs => [ $parse->prioritized_symbol( $lhs, $_ ) ], description => ( qq{Internal rule for symbol <$lhs> priority transition from } . ( $_ - 1 ) . qq{ to $_} ), @arg0_action } } 1 .. $priority_count - 1 ); RULE: for my $working_rule (@working_rules) { my ( $priority, $rhs, $adverb_list ) = @{$working_rule}; my @new_rhs = @{ $rhs->{rhs} }; my @arity = grep { $new_rhs[$_] eq $lhs } 0 .. $#new_rhs; my $rhs_length = scalar @new_rhs; my $current_exp = $parse->prioritized_symbol( $lhs, $priority ); my @mask = @{ $rhs->{mask} }; if ( ( substr $subgrammar, 0, 1 ) eq 'L' and grep { !$_ } @mask ) { Marpa::R2::exception( 'hidden symbols are not allowed in lexical rules (rules LHS was "', $lhs, '")' ); } my %new_xs_rule = ( lhs => $current_exp ); $new_xs_rule{mask} = \@mask; my $action; my $assoc; my $blessing; my $naming; my $rank; my $null_ranking; ADVERB: for my $key ( keys %{$adverb_list} ) { my $value = $adverb_list->{$key}; if ( $key eq 'action' ) { $action = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'assoc' ) { $assoc = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'bless' ) { $blessing = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'name' ) { $naming = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'null_ranking' ) { $null_ranking = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'rank' ) { $rank = $adverb_list->{$key}; next ADVERB; } my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{Adverb "$key" not allowed in a prioritized rule\n}, ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end ADVERB: for my $key ( keys %{$adverb_list} ) $assoc //= 'L'; $action //= $default_adverbs->{action}; if ( defined $action ) { Marpa::R2::exception( 'actions not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $new_xs_rule{action} = $action; } ## end if ( defined $action ) $null_ranking //= $default_adverbs->{null_ranking}; if ( defined $null_ranking ) { Marpa::R2::exception( 'null-ranking not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $new_xs_rule{null_ranking} = $null_ranking; } ## end if ( defined $rank ) $rank //= $default_adverbs->{rank}; if ( defined $rank ) { Marpa::R2::exception( 'ranks not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $new_xs_rule{rank} = $rank; } ## end if ( defined $rank ) $blessing //= $default_adverbs->{bless}; if ( defined $blessing and ( substr $subgrammar, 0, 1 ) eq 'L' ) { Marpa::R2::exception( 'bless option not allowed in lexical rules (rules LHS was "', $lhs, '")' ); } $parse->bless_hash_rule( \%new_xs_rule, $blessing, $naming, $lhs ); my $next_priority = $priority + 1; $next_priority = 0 if $next_priority >= $priority_count; my $next_exp = $parse->prioritized_symbol( $lhs, $next_priority); if ( not scalar @arity ) { $new_xs_rule{rhs} = \@new_rhs; push @{$rules}, \%new_xs_rule; next RULE; } if ( scalar @arity == 1 ) { die 'Unnecessary unit rule in priority rule' if $rhs_length == 1; $new_rhs[ $arity[0] ] = $current_exp; } DO_ASSOCIATION: { if ( $assoc eq 'L' ) { $new_rhs[ $arity[0] ] = $current_exp; for my $rhs_ix ( @arity[ 1 .. $#arity ] ) { $new_rhs[$rhs_ix] = $next_exp; } last DO_ASSOCIATION; } ## end if ( $assoc eq 'L' ) if ( $assoc eq 'R' ) { $new_rhs[ $arity[-1] ] = $current_exp; for my $rhs_ix ( @arity[ 0 .. $#arity - 1 ] ) { $new_rhs[$rhs_ix] = $next_exp; } last DO_ASSOCIATION; } ## end if ( $assoc eq 'R' ) if ( $assoc eq 'G' ) { for my $rhs_ix ( @arity[ 0 .. $#arity ] ) { $new_rhs[$rhs_ix] = $parse->prioritized_symbol( $lhs, 0 ); } last DO_ASSOCIATION; } ## end if ( $assoc eq 'G' ) die qq{Unknown association type: "$assoc"}; } ## end DO_ASSOCIATION: $new_xs_rule{rhs} = \@new_rhs; push @{$rules}, \%new_xs_rule; } ## end RULE: for my $working_rule (@working_rules) ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::priority_rule::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::empty_rule::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $raw_lhs, $op_declare, $raw_adverb_list ) = @{$values}; my $current_lexer = $parse->{current_lexer}; my $subgrammar; if ( $op_declare->op() eq q{::=} ) { if ( $current_lexer ne 'L0' ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die "G1 rules currently allowed only when L0 is current lexer\n", qq{ An empty rule was found when "$current_lexer" was the current lexer\n"}, " Location was line $line, column $column\n", ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end if ( $current_lexer ne 'L0' ) $subgrammar = 'G1'; } ## end if ( $op_declare->op() eq q{::=} ) else { $subgrammar = $current_lexer; } my $lhs = $raw_lhs->name($parse); $parse->{'first_lhs'} //= $lhs if $subgrammar eq 'G1'; local $Marpa::R2::Internal::SUBGRAMMAR = $subgrammar; my %rule = ( lhs => $lhs, description => qq{Empty rule for <$lhs>}, rhs => [] ); my $adverb_list = $raw_adverb_list->evaluate($parse); my $default_adverbs = $parse->{default_adverbs}->{$subgrammar}; my $action; my $blessing; my $naming; my $rank; my $null_ranking; ADVERB: for my $key ( keys %{$adverb_list} ) { my $value = $adverb_list->{$key}; if ( $key eq 'action' ) { $action = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'bless' ) { $blessing = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'name' ) { $naming = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'null_ranking' ) { $null_ranking = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'rank' ) { $rank = $adverb_list->{$key}; next ADVERB; } my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{Adverb "$key" not allowed in an empty rule\n}, ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end ADVERB: for my $key ( keys %{$adverb_list} ) $action //= $default_adverbs->{action}; if ( defined $action ) { Marpa::R2::exception( 'actions not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $rule{action} = $action; } ## end if ( defined $action ) $null_ranking //= $default_adverbs->{null_ranking}; if ( defined $null_ranking ) { Marpa::R2::exception( 'null-ranking not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $rule{null_ranking} = $null_ranking; } ## end if ( defined $null_ranking ) $rank //= $default_adverbs->{rank}; if ( defined $rank ) { Marpa::R2::exception( 'ranks not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $rule{rank} = $rank; } ## end if ( defined $rank ) $blessing //= $default_adverbs->{bless}; if ( defined $blessing and ( substr $subgrammar, 0, 1 ) eq 'L' ) { Marpa::R2::exception( 'bless option not allowed in lexical rules (rules LHS was "', $lhs, '")' ); } $parse->bless_hash_rule( \%rule, $blessing, $naming, $lhs ); # mask not needed push @{ $parse->{rules}->{$subgrammar} }, \%rule; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::empty_rule::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::lexeme_rule::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $symbol, $unevaluated_adverb_list ) = @{$values}; my $symbol_name = $symbol->name(); my $declarations = $parse->{lexeme_declarations}->{$symbol_name}; if ( defined $declarations ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die "Duplicate lexeme rule for <$symbol_name>\n", " Only one lexeme rule is allowed for each symbol\n", " Location was line $line, column $column\n", ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end if ( defined $declarations ) my $adverb_list = $unevaluated_adverb_list->evaluate(); my %declarations; ADVERB: for my $key ( keys %{$adverb_list} ) { my $raw_value = $adverb_list->{$key}; if ( $key eq 'priority' ) { $declarations{$key} = $raw_value + 0; next ADVERB; } if ( $key eq 'pause' ) { if ( $raw_value eq 'before' ) { $declarations{$key} = -1; next ADVERB; } if ( $raw_value eq 'after' ) { $declarations{$key} = 1; next ADVERB; } my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{Bad value for "pause" adverb: "$raw_value"}, " Location was line $line, column $column\n", ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end if ( $key eq 'pause' ) if ( $key eq 'event' ) { $declarations{$key} = $raw_value; next ADVERB; } if ( $key eq 'latm' ) { $declarations{$key} = $raw_value; next ADVERB; } my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{"$key" adverb not allowed in lexeme rule"\n}, " Location was line $line, column $column\n", ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end ADVERB: for my $key ( keys %{$adverb_list} ) if ( exists $declarations{'event'} and not exists $declarations{'pause'} ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{"event" adverb not allowed without "pause" adverb in lexeme rule"\n}, " Location was line $line, column $column\n", ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end if ( exists $declarations{'event'} and not exists $declarations...) $parse->{lexeme_declarations}->{$symbol_name} = \%declarations; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::lexeme_rule::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::statements::evaluate { my ( $data, $parse ) = @_; my ( undef, undef, @statement_list ) = @{$data}; map { $_->evaluate($parse) } @statement_list; return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::statements::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::statement::evaluate { my ( $data, $parse ) = @_; my ( undef, undef, $child ) = @{$data}; $child->evaluate($parse); ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::statement::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::null_statement::evaluate { return undef; } sub Marpa::R2::Internal::MetaAST_Nodes::statement_group::evaluate { my ( $data, $parse ) = @_; my ( undef, undef, $statements ) = @{$data}; $statements->evaluate($parse); ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } sub Marpa::R2::Internal::MetaAST::start_rule_create { my ( $parse, $symbol_name ) = @_; my $start_lhs = '[:start]'; $parse->{'default_g1_start_action'} = $parse->{'default_adverbs'}->{'G1'}->{'action'}; $parse->{'symbols'}->{'G1'}->{$start_lhs} = { display_form => ':start', description => 'Internal G1 start symbol' }; push @{ $parse->{rules}->{G1} }, { lhs => $start_lhs, rhs => [$symbol_name], action => '::first' }; } ## end sub Marpa::R2::Internal::MetaAST::start_rule_create sub Marpa::R2::Internal::MetaAST_Nodes::start_rule::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $symbol ) = @{$values}; if ( defined $parse->{'start_lhs'} ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{There are two start rules\n}, qq{ That is not allowed\n}, ' The second start rule is ', $parse->substring( $start, $length ), "\n", " Problem occurred at line $line, column $column\n"; } ## end if ( defined $parse->{'start_lhs'} ) $parse->{'start_lhs'} = $symbol->name($parse); ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::start_rule::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::discard_rule::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $symbol ) = @{$values}; my $lexer_name = $parse->{current_lexer}; local $Marpa::R2::Internal::SUBGRAMMAR = $lexer_name; my $discard_lhs = '[:discard]'; $parse->symbol_names_set( $discard_lhs, 'L', { display_form => ':discard', description => qq{Internal LHS for lexer "$lexer_name" discard} } ); my $rhs = $symbol->names($parse); push @{ $parse->{rules}->{$lexer_name} }, { description => ( "Discard rule for " . join q{ }, map { '<' . $_ . '>' } @{$rhs} ), lhs => $discard_lhs, rhs => $rhs }; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::discard_rule::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::quantified_rule::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $lhs, $op_declare, $rhs, $quantifier, $proto_adverb_list ) = @{$values}; my $subgrammar; my $current_lexer = $parse->{current_lexer}; if ( $op_declare->op() eq q{::=} ) { if ( $current_lexer ne 'L0' ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die "G1 rules currently allowed only when L0 is current lexer\n", qq{ A quantified rule was found when "$current_lexer" was the current lexer\n"}, " Location was line $line, column $column\n", ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end if ( $current_lexer ne 'L0' ) $subgrammar = 'G1'; } ## end if ( $op_declare->op() eq q{::=} ) else { $subgrammar = $current_lexer; } my $lhs_name = $lhs->name($parse); $parse->{'first_lhs'} //= $lhs_name if $subgrammar eq 'G1'; local $Marpa::R2::Internal::SUBGRAMMAR = $subgrammar; my $adverb_list = $proto_adverb_list->evaluate($parse); my $default_adverbs = $parse->{default_adverbs}->{$subgrammar}; # Some properties of the sequence rule will not be altered # no matter how complicated this gets my %sequence_rule = ( rhs => [ $rhs->name($parse) ], min => ( $quantifier->evaluate($parse) eq q{+} ? 1 : 0 ) ); my @rules = ( \%sequence_rule ); my $action; my $blessing; my $naming; my $separator; my $proper; my $rank; my $null_ranking; ADVERB: for my $key ( keys %{$adverb_list} ) { my $value = $adverb_list->{$key}; if ( $key eq 'action' ) { $action = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'bless' ) { $blessing = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'name' ) { $naming = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'proper' ) { $proper = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'rank' ) { $rank = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'null_ranking' ) { $null_ranking = $adverb_list->{$key}; next ADVERB; } if ( $key eq 'separator' ) { $separator = $adverb_list->{$key}; next ADVERB; } my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{Adverb "$key" not allowed in quantified rule\n}, ' Rule was ', $parse->substring( $start, $length ), "\n"; } ## end ADVERB: for my $key ( keys %{$adverb_list} ) # mask not needed $sequence_rule{lhs} = $lhs_name; $sequence_rule{separator} = $separator if defined $separator; $sequence_rule{proper} = $proper if defined $proper; $action //= $default_adverbs->{action}; if ( defined $action ) { Marpa::R2::exception( 'actions not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $sequence_rule{action} = $action; } ## end if ( defined $action ) $null_ranking //= $default_adverbs->{null_ranking}; if ( defined $null_ranking ) { Marpa::R2::exception( 'null-ranking not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $sequence_rule{null_ranking} = $null_ranking; } ## end if ( defined $null_ranking ) $rank //= $default_adverbs->{rank}; if ( defined $rank ) { Marpa::R2::exception( 'ranks not allowed in lexical rules (rules LHS was "', $lhs, '")' ) if ( substr $subgrammar, 0, 1 ) eq 'L'; $sequence_rule{rank} = $rank; } ## end if ( defined $rank ) $blessing //= $default_adverbs->{bless}; if ( defined $blessing and ( substr $subgrammar, 0, 1 ) eq 'L' ) { Marpa::R2::exception( 'bless option not allowed in lexical rules (rules LHS was "', $lhs, '")' ); } $parse->bless_hash_rule( \%sequence_rule, $blessing, $naming, $lhs_name ); push @{ $parse->{rules}->{$subgrammar} }, @rules; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::quantified_rule::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::completion_event_declaration::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $raw_event_name, $raw_symbol_name ) = @{$values}; my $event_name = $raw_event_name->name(); my $symbol_name = $raw_symbol_name->name(); my $completion_events = $parse->{completion_events} //= {}; if ( defined $completion_events->{$symbol_name} ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{Completion event for symbol "$symbol_name" declared twice\n}, qq{ That is not allowed\n}, ' Second declaration was ', $parse->substring( $start, $length ), "\n", " Problem occurred at line $line, column $column\n"; } ## end if ( defined $completion_events->{$symbol_name} ) $completion_events->{$symbol_name} = $event_name; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::completion_event_declaration::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::nulled_event_declaration::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $raw_event_name, $raw_symbol_name ) = @{$values}; my $event_name = $raw_event_name->name(); my $symbol_name = $raw_symbol_name->name(); my $nulled_events = $parse->{nulled_events} //= {}; if ( defined $nulled_events->{$symbol_name} ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{nulled event for symbol "$symbol_name" declared twice\n}, qq{ That is not allowed\n}, ' Second declaration was ', $parse->substring( $start, $length ), "\n", " Problem occurred at line $line, column $column\n"; } ## end if ( defined $nulled_events->{$symbol_name} ) $nulled_events->{$symbol_name} = $event_name; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::nulled_event_declaration::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::prediction_event_declaration::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $raw_event_name, $raw_symbol_name ) = @{$values}; my $event_name = $raw_event_name->name(); my $symbol_name = $raw_symbol_name->name(); my $prediction_events = $parse->{prediction_events} //= {}; if ( defined $prediction_events->{$symbol_name} ) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{prediction event for symbol "$symbol_name" declared twice\n}, qq{ That is not allowed\n}, ' Second declaration was ', $parse->substring( $start, $length ), "\n", " Problem occurred at line $line, column $column\n"; } ## end if ( defined $prediction_events->{$symbol_name} ) $prediction_events->{$symbol_name} = $event_name; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::prediction_event_declaration::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::current_lexer_statement::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $lexer_name_object ) = @{$values}; my $raw_lexer_name = $lexer_name_object->name(); if ( $raw_lexer_name eq 'L0' ) { $parse->{current_lexer} = $raw_lexer_name; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } if ( $raw_lexer_name =~ m/\A [[:upper:]] [[:digit:]]+ \z/xms) { my ( $line, $column ) = $parse->{meta_recce}->line_column($start); die qq{Attempt to name a new lexer "$raw_lexer_name"\n}, qq{ Lexer names of the form [A-Z][0-9]+ are reserved\n}, qq{ Please choose another name\n}, " Problem occurred at line $line, column $column\n"; } ## end if ( defined $prediction_events->{$symbol_name} ) my $lexer_name .= 'L-' . $raw_lexer_name; $parse->{current_lexer} = $lexer_name; ## no critic(Subroutines::ProhibitExplicitReturnUndef) return undef; } sub Marpa::R2::Internal::MetaAST_Nodes::alternatives::evaluate { my ( $values, $parse ) = @_; return bless [ map { $_->evaluate( $_, $parse ) } @{$values} ], ref $values; } sub Marpa::R2::Internal::MetaAST_Nodes::alternative::evaluate { my ( $values, $parse ) = @_; my ( $start, $length, $rhs, $adverbs ) = @{$values}; my $alternative = eval { Marpa::R2::Internal::MetaAST::Proto_Alternative->combine( map { $_->evaluate($parse) } $rhs, $adverbs ); }; if ( not $alternative ) { Marpa::R2::exception( $EVAL_ERROR, "\n", q{ Alternative involved was }, $parse->substring( $start, $length ) ); } ## end if ( not $alternative ) return $alternative; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::alternative::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::single_symbol::names { my ( $values, $parse ) = @_; my ( undef, undef, $symbol ) = @{$values}; return $symbol->names($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::single_symbol::name { my ( $values, $parse ) = @_; my ( undef, undef, $symbol ) = @{$values}; return $symbol->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::single_symbol::evaluate { my ( $values, $parse ) = @_; my ( undef, undef, $symbol ) = @{$values}; return Marpa::R2::Internal::MetaAST::Symbol_List->new( $symbol->name($parse) ); } ## end sub Marpa::R2::Internal::MetaAST_Nodes::single_symbol::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::Symbol::evaluate { my ( $values, $parse ) = @_; my ( undef, undef, $symbol ) = @{$values}; return $symbol->evaluate($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::symbol::name { my ( $self, $parse ) = @_; return $self->[2]->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::symbol::names { my ( $self, $parse ) = @_; return $self->[2]->names($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::symbol_name::evaluate { my ($self) = @_; return $self->[2]; } sub Marpa::R2::Internal::MetaAST_Nodes::symbol_name::name { my ( $self, $parse ) = @_; return $self->evaluate($parse)->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::symbol_name::names { my ( $self, $parse ) = @_; return [ $self->name($parse) ]; } sub Marpa::R2::Internal::MetaAST_Nodes::adverb_list::evaluate { my ( $data, $parse ) = @_; my ( undef, undef, $adverb_list_items ) = @{$data}; return undef if not defined $adverb_list_items; return $adverb_list_items->evaluate($parse); } ## end sub Marpa::R2::Internal::MetaAST_Nodes::adverb_list::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::null_adverb::evaluate { return {}; } sub Marpa::R2::Internal::MetaAST_Nodes::adverb_list_items::evaluate { my ( $data, $parse ) = @_; my ( undef, undef, @raw_items ) = @{$data}; my (@adverb_items) = map { $_->evaluate($parse) } @raw_items; return Marpa::R2::Internal::MetaAST::Proto_Alternative->combine( @adverb_items); } ## end sub Marpa::R2::Internal::MetaAST_Nodes::adverb_list::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::character_class::name { my ( $self, $parse ) = @_; return $self->evaluate($parse)->name($parse); } sub Marpa::R2::Internal::MetaAST_Nodes::character_class::names { my ( $self, $parse ) = @_; return [ $self->name($parse) ]; } sub Marpa::R2::Internal::MetaAST_Nodes::character_class::evaluate { my ( $values, $parse ) = @_; my $character_class = $values->[2]; my $subgrammar = $Marpa::R2::Internal::SUBGRAMMAR; $DB::single = 1 if not defined $subgrammar; if (( substr $subgrammar, 0, 1 ) eq 'L') { return Marpa::R2::Internal::MetaAST::Symbol_List->char_class_to_symbol( $parse, $character_class ); } # If here, in G1 # Character classes and strings always go into L0, for now my $lexer_symbol = do { local $Marpa::R2::Internal::SUBGRAMMAR = 'L0'; Marpa::R2::Internal::MetaAST::Symbol_List->char_class_to_symbol( $parse, $character_class ); }; my $lexical_lhs = $parse->internal_lexeme($character_class); my $lexical_rhs = $lexer_symbol->names($parse); my %lexical_rule = ( lhs => $lexical_lhs, rhs => $lexical_rhs, mask => [1], ); push @{ $parse->{rules}->{L0} }, \%lexical_rule; my $g1_symbol = Marpa::R2::Internal::MetaAST::Symbol_List->new($lexical_lhs); return $g1_symbol; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::character_class::evaluate sub Marpa::R2::Internal::MetaAST_Nodes::single_quoted_string::evaluate { my ( $values, $parse ) = @_; my ( undef, undef, $string ) = @{$values}; my @symbols = (); my $end_of_string = rindex $string, q{'}; my $unmodified_string = substr $string, 0, $end_of_string+1; my $raw_flags = substr $string, $end_of_string+1; my $flags = Marpa::R2::Internal::MetaAST::flag_string_to_flags($raw_flags); my $subgrammar = $Marpa::R2::Internal::SUBGRAMMAR; # If we are currently in a lexical grammar, the strings go there # If we are currently in G1, the strings always go into L0 my $lexical_grammar = $subgrammar eq 'G1' ? 'L0' : $subgrammar; for my $char_class ( map { '[' . ( quotemeta $_ ) . ']' . $flags } split //xms, substr $unmodified_string, 1, -1 ) { local $Marpa::R2::Internal::SUBGRAMMAR = $lexical_grammar; my $symbol = Marpa::R2::Internal::MetaAST::Symbol_List->char_class_to_symbol( $parse, $char_class ); push @symbols, $symbol; } ## end for my $char_class ( map { '[' . ( quotemeta $_ ) . ']'...}) my $list = Marpa::R2::Internal::MetaAST::Symbol_List->combine(@symbols); return $list if $Marpa::R2::Internal::SUBGRAMMAR ne 'G1'; my $lexical_lhs = $parse->internal_lexeme($string); my $lexical_rhs = $list->names($parse); my %lexical_rule = ( lhs => $lexical_lhs, rhs => $lexical_rhs, description => "Internal rule for single-quoted string $string", mask => [ map { ; 1 } @{$lexical_rhs} ], ); push @{ $parse->{rules}->{$lexical_grammar} }, \%lexical_rule; my $g1_symbol = Marpa::R2::Internal::MetaAST::Symbol_List->new($lexical_lhs); return $g1_symbol; } ## end sub Marpa::R2::Internal::MetaAST_Nodes::single_quoted_string::evaluate package Marpa::R2::Internal::MetaAST::Symbol_List; use English qw( -no_match_vars ); sub new { my ( $class, $name ) = @_; return bless { names => [ q{} . $name ], mask => [1] }, $class; } sub combine { my ( $class, @lists ) = @_; my $self = {}; $self->{names} = [ map { @{ $_->names() } } @lists ]; $self->{mask} = [ map { @{ $_->mask() } } @lists ]; return bless $self, $class; } ## end sub combine sub Marpa::R2::Internal::MetaAST::char_class_to_re { my ($cc_components) = @_; die if ref $cc_components ne 'ARRAY'; my ( $char_class, $flags ) = @{$cc_components}; $flags = $flags ? '(' . q{?} . $flags . ')' : q{}; my $regex; my $error; if ( not defined eval { $regex = qr/$flags$char_class/xms; 1; } ) { $error = qq{Problem in evaluating character class: "$char_class"\n}; $error .= qq{ Flags were "$flags"\n} if $flags; $error .= $EVAL_ERROR; } return $regex, $error; } sub Marpa::R2::Internal::MetaAST::flag_string_to_flags { my ($raw_flag_string) = @_; return q{} if not $raw_flag_string; my @raw_flags = split m/:/xms, $raw_flag_string; my %flags = (); RAW_FLAG: for my $raw_flag (@raw_flags) { next RAW_FLAG if not $raw_flag; if ( $raw_flag eq 'i' ) { $flags{'i'} = 1; next RAW_FLAG; } if ( $raw_flag eq 'ic' ) { $flags{'i'} = 1; next RAW_FLAG; } Carp::croak( qq{Bad flag for character class\n}, qq{ Flag string was $raw_flag_string\n}, qq{ Bad flag was $raw_flag\n} ); } ## end RAW_FLAG: for my $raw_flag (@raw_flags) my $cooked_flags = join q{}, sort keys %flags; return $cooked_flags; } ## end sub flag_string_to_flags # Return the character class symbol name, # after ensuring everything is set up properly sub char_class_to_symbol { my ( $class, $parse, $char_class ) = @_; my $end_of_char_class = rindex $char_class, q{]}; my $unmodified_char_class = substr $char_class, 0, $end_of_char_class+1; my $raw_flags = substr $char_class, $end_of_char_class+1; my $flags = Marpa::R2::Internal::MetaAST::flag_string_to_flags($raw_flags); my $subgrammar = $Marpa::R2::Internal::SUBGRAMMAR; # character class symbol name always start with TWO left square brackets my $symbol_name = '[' . $unmodified_char_class . $flags . ']'; $parse->{character_classes} //= {}; my $cc_hash = $parse->{character_classes}; my ( undef, $symbol ) = $cc_hash->{$symbol_name}; if ( not defined $symbol ) { my $cc_components = [$unmodified_char_class, $flags]; # Fast fail on badly formed char_class -- we re-evaluate the regex just in time # before we register characters. my ( $regex, $eval_error ) = Marpa::R2::Internal::MetaAST::char_class_to_re($cc_components); Carp::croak( 'Bad Character class: ', $char_class, "\n", 'Perl said ', $eval_error ) if not $regex; $symbol = Marpa::R2::Internal::MetaAST::Symbol_List->new($symbol_name); $cc_hash->{$symbol_name} = [ $cc_components, $symbol ]; $parse->symbol_names_set( $symbol_name, $subgrammar, { dsl_form => $char_class, display_form => $char_class, description => "Character class: $char_class" } ); } ## end if ( not defined $symbol ) return $symbol; } ## end sub char_class_to_symbol sub Marpa::R2::Internal::MetaAST::Parse::symbol_names_set { my ( $parse, $symbol, $subgrammar, $args ) = @_; my $symbol_type = $subgrammar eq 'G1' ? 'G1' : 'L'; for my $arg_type (keys %{$args}) { my $value = $args->{$arg_type}; $parse->{symbols}->{$symbol_type}->{$symbol}->{$arg_type} = $value; } } # Return the priotized symbol name, # after ensuring everything is set up properly sub Marpa::R2::Internal::MetaAST::Parse::prioritized_symbol { my ( $parse, $base_symbol, $priority ) = @_; # character class symbol name always start with TWO left square brackets my $symbol_name = $base_symbol . '[' . $priority . ']'; my $symbol_data = $parse->{symbols}->{$Marpa::R2::Internal::SUBGRAMMAR eq 'G1' ? 'G1' : 'L'}->{$symbol_name}; return $symbol_name if defined $symbol_data; my $display_form = ( $base_symbol =~ m/\s/xms ) ? "<$base_symbol>" : $base_symbol; $parse->symbol_names_set( $symbol_name, $Marpa::R2::Internal::SUBGRAMMAR, { legacy_name => $base_symbol, dsl_form => $base_symbol, display_form => $display_form, description => "<$base_symbol> at priority $priority" } ); return $symbol_name; } ## end sub Marpa::R2::Internal::MetaAST::Parse::prioritized_symbol # Return the prioritized symbol name, # after ensuring everything is set up properly sub Marpa::R2::Internal::MetaAST::Parse::internal_lexeme { my ( $parse, $dsl_form, @grammars ) = @_; # character class symbol name always start with TWO left square brackets my $lexical_lhs_index = $parse->{lexical_lhs_index}++; my $lexical_symbol = "[Lex-$lexical_lhs_index]"; my %names = ( dsl_form => $dsl_form, display_form => $dsl_form, description => qq{Internal lexical symbol for "$dsl_form"} ); $parse->symbol_names_set( $lexical_symbol, $_, \%names ) for qw(G1 L); return $lexical_symbol; } ## end sub Marpa::R2::Internal::MetaAST::Parse::internal_lexeme sub name { my ($self) = @_; my $names = $self->{names}; Marpa::R2::exception( 'list->name() on symbol list of length ', scalar @{$names} ) if scalar @{$names} != 1; return $self->{names}->[0]; } ## end sub name sub names { return shift->{names} } sub mask { return shift->{mask} } sub mask_set { my ( $self, $mask ) = @_; return $self->{mask} = [ map {$mask} @{ $self->{mask} } ]; } 1; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/Stuifzand.pm0000444000000000000000000001554112342464707017445 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::Stuifzand; use 5.010; use strict; use warnings; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic(BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic package Marpa::R2::Internal::Stuifzand; use English qw( -no_match_vars ); # Internal names end in ']' and are distinguished by prefix. # # Suffixed with '[prec%d]' -- # a symbol created to implement precedence. # Suffix is removed to restore 'original'. # # Prefixed with '[[' -- a character class # These are their own 'original'. # # Prefixed with '[:' -- a reserved symbol, one which in the # grammars start with a colon. # These are their own 'original'. # # Of the form '[Lex-42]' - where for '42' any other # decimal number can be subsituted. Anonymous lexicals. # These symbols are their own originals. # # Prefixed with '[SYMBOL#' - a unnamed internal symbol. # Seeing these # indicates some sort of internal error. If seen, # they will be treated as their own original. # # Suffixed with '[Sep]' indicates an internal version # of a sequence separator. These are their own # original, because otherwise the "original" name # would conflict with the LHS of the sequence. # my %node_status = map { ; ($_ , q{} ) } qw( action action_name adverb_item adverb_list adverb_list_items alternative alternatives array_descriptor bare_name blessing blessing_name boolean bracketed_name default_rule empty_rule group_association left_association lhs op_declare op_declare_bnf parenthesized_rhs_primary_list Perl_name priorities priority_rule proper_specification quantified_rule quantifier reserved_action_name reserved_blessing_name rhs rhs_primary rhs_primary_list right_association separator_specification single_symbol standard_name start_rule statement statements symbol symbol_name ); $node_status{'Marpa::R2::Internal::MetaAST'} = q{}; $node_status{array_descriptor} = "Actions in the form of array descriptors are not allowed"; $node_status{character_class} = "Character classes are not allowed"; $node_status{completion_event_declaration} = "Completion events are not allowed"; $node_status{discard_rule} = ":discard rules are not allowed"; $node_status{event_specification} = qq{The "event" adverb is not allowed}; $node_status{latm_specification} = qq{The "latm" adverb is not allowed}; $node_status{lexeme_default_statement} = "The lexeme default statement is not allowed"; $node_status{lexeme_rule} = "Lexeme statements are not allowed"; $node_status{nulled_event_declaration} = "Nulled events are not allowed"; $node_status{op_declare_match} = "lexical rules are not allowed"; $node_status{pause_specification} = "The pause adverb is not allowed"; $node_status{prediction_event_declaration} = "Prediction events are not allowed"; $node_status{priority_specification} = "The priority adverb is not allowed"; $node_status{single_quoted_string} = "Quoted strings are not allowed"; $node_status{alternative_name} = "Alternative naming is not allowed"; $node_status{naming} = "Alternative naming is not allowed"; my %catch_error_node = map { ; ($_ , 1 ) } qw( alternative statement ); # This code goes to some trouble to report errors with a large enough contet # to be meaningful -- rules or alternatives sub Marpa::R2::Internal::Stuifzand::check_ast_node { my ($node) = @_; my $ref_type = ref $node; return if not $ref_type; $ref_type =~ s/\A Marpa::R2::Internal::MetaAST_Nodes:: //xms; my $report_error = 0; my $problem = $node_status{$ref_type}; my $catch_error = $catch_error_node{$ref_type}; return qq{Internal error: Unknown AST node (type "$ref_type") in Stuifzand grammar} if not defined $problem; # "Normal" meaning other than catching errors NORMAL_PROCESSING: { if ($problem) { return $problem if not $catch_error_node{$ref_type}; last NORMAL_PROCESSING; } for my $sub_node ( @{$node} ) { $problem = Marpa::R2::Internal::Stuifzand::check_ast_node($sub_node); if ($problem) { return $problem if not $catch_error; last NORMAL_PROCESSING; } } ## end for my $sub_node ( @{$node} ) return; } ## end NORMAL_PROCESSING: # If we are here, we are catching an error my ( $start, $end ) = @{$node}; my $problem_was_here = substr ${$Marpa::R2::Internal::P_SOURCE}, $start, ($end-$start+1); chomp $problem_was_here; chomp $problem; Marpa::R2::exception( "Stuifzand (BNF) interface grammar is using a disallowed feature\n", q{ } . $problem . "\n", " Problem was in the following text:\n", $problem_was_here, "\n" ); } ## end sub Marpa::R2::Internal::Stuifzand::check_ast_node sub parse_rules { my ($p_rules_source) = @_; my $self = {}; my $ast = Marpa::R2::Internal::MetaAST->new($p_rules_source); { local $Marpa::R2::Internal::P_SOURCE = $p_rules_source; my $problem = Marpa::R2::Internal::Stuifzand::check_ast_node( $ast->{top_node} ); ## Uncaught problem -- should not happen if ($problem) { Marpa::R2::exception( "Stuifzand (BNF) interface grammar has a problem\n", q{ } . $problem . "\n", ); } ## end if ($problem) } my $hashed_ast = $ast->ast_to_hash(); my $start_lhs = $hashed_ast->{'start_lhs'} // $hashed_ast->{'first_lhs'}; Marpa::R2::exception( 'No rules in Stuifzand grammar', ) if not defined $start_lhs; my $internal_start_lhs = '[:start]'; $hashed_ast->{'default_g1_start_action'} = $hashed_ast->{'default_adverbs'}->{'G1'}->{'action'}; $hashed_ast->{'symbols'}->{'G1'}->{$internal_start_lhs} = { display_form => ':start', description => 'Internal G1 start symbol' }; push @{ $hashed_ast->{rules}->{G1} }, { lhs => $internal_start_lhs, rhs => [$start_lhs], action => '::first' }; $self->{rules} = $hashed_ast->{rules}->{G1}; return $self; } ## end sub parse_rules 1; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/Thin/0000755000000000000000000000000012342464706016035 5ustar rootrootMarpa-R2-2.086000~dfsg/lib/Marpa/R2/Thin/Trace.pm0000444000000000000000000002351312342464706017433 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::Thin::Trace; use 5.010; use warnings; use strict; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; $VERSION = eval $VERSION; sub new { my ( $class, $grammar ) = @_; my $self = bless {}, $class; $self->{g} = $grammar; $self->{symbol_by_name} = {}; $self->{symbol_names} = {}; return $self; } ## end sub new sub grammar { my ($self) = @_; return $self->{g}; } sub symbol_by_name { my ( $self, $name ) = @_; return $self->{symbol_by_name}->{$name}; } sub symbol_name { my ( $self, $symbol_id ) = @_; my $symbol_name = $self->{symbol_name}->[$symbol_id]; $symbol_name = 'R' . $symbol_id if not defined $symbol_name; return $symbol_name; } ## end sub symbol_name sub formatted_symbol_name { my ( $self, $symbol_id ) = @_; my $symbol_name = $self->symbol_name($symbol_id); # As-is if all word characters return $symbol_name if $symbol_name =~ m/ \A \w* \z/xms; # As-is if ends in right bracket return $symbol_name if $symbol_name =~ m/ \] \z/xms; return '<' . $symbol_name . '>'; } sub symbol_name_set { my ( $self, $name, $symbol_id ) = @_; $self->{symbol_name}->[$symbol_id] = $name; $self->{symbol_by_name}->{$name} = $symbol_id; return $symbol_id; } ## end sub symbol_name_set sub symbol_new { my ( $self, $name ) = @_; return $self->symbol_name_set( $name, $self->{g}->symbol_new() ); } sub symbol_force { my ( $self, $name ) = @_; return $self->{symbol_by_name}->{$name} // $self->symbol_new($name); } sub rule { my ( $self, $rule_id ) = @_; my $grammar = $self->{g}; my $rule_length = $grammar->rule_length($rule_id); my $lhs = $self->symbol_name( $grammar->rule_lhs($rule_id) ); my @rhs = map { $self->symbol_name( $grammar->rule_rhs( $rule_id, $_ ) ) } ( 0 .. $rule_length - 1 ); return ($lhs, @rhs); } # Expand a rule into a list of symbol IDs sub rule_expand { my ( $self, $rule_id ) = @_; my $grammar = $self->{g}; my $rule_length = $grammar->rule_length($rule_id); return if not defined $rule_length; my $lhs = ( $grammar->rule_lhs($rule_id) ); return ( $lhs, map { $grammar->rule_rhs( $rule_id, $_ ) } ( 0 .. $rule_length - 1 ) ); } ## end sub rule_expand sub dotted_rule { my ( $self, $rule_id, $dot_position ) = @_; my $grammar = $self->{g}; my $rule_length = $grammar->rule_length($rule_id); $dot_position = $rule_length if $dot_position < 0; my $lhs = $self->formatted_symbol_name( $grammar->rule_lhs($rule_id) ); my @rhs = map { $self->formatted_symbol_name( $grammar->rule_rhs( $rule_id, $_ ) ) } ( 0 .. $rule_length - 1 ); $dot_position = 0 if $dot_position < 0; splice( @rhs, $dot_position, 0, q{.} ); return join q{ }, $lhs, q{::=}, @rhs; } ## end sub dotted_rule sub brief_rule { my ( $self, $rule_id ) = @_; my $grammar = $self->{g}; my $rule_length = $grammar->rule_length($rule_id); my $lhs = $self->formatted_symbol_name( $grammar->rule_lhs($rule_id) ); my @rhs = map { $self->formatted_symbol_name( $grammar->rule_rhs( $rule_id, $_ ) ) } ( 0 .. $rule_length - 1 ); my $minimum = $grammar->sequence_min($rule_id); my @quantifier = (); if (defined $minimum) { push @quantifier, ($minimum <= 0 ? q{ *} : q{ +}); } return join q{ }, $lhs, q{::=}, @rhs, @quantifier; } ## end sub dotted_rule sub progress_report { my ( $self, $recce, $ordinal ) = @_; my $result = q{}; $ordinal //= $recce->latest_earley_set(); $recce->progress_report_start($ordinal); ITEM: while (1) { my ( $rule_id, $dot_position, $origin ) = $recce->progress_item(); last ITEM if not defined $rule_id; $result .= q{@} . $origin . q{: } . $self->dotted_rule( $rule_id, $dot_position ) . "\n"; } ## end ITEM: while (1) $recce->progress_report_finish(); return $result; } ## end sub progress_report sub lexer_progress_report { my ( $self, $slr, $ordinal ) = @_; my $thin_slr = $slr->[Marpa::R2::Internal::Scanless::R::C]; my $result = q{}; $ordinal //= $thin_slr->lexer_latest_earley_set(); $thin_slr->lexer_progress_report_start($ordinal); ITEM: while (1) { my ( $rule_id, $dot_position, $origin ) = $thin_slr->lexer_progress_item(); last ITEM if not defined $rule_id; $result .= q{@} . $origin . q{: } . $self->dotted_rule( $rule_id, $dot_position ) . "\n"; } ## end ITEM: while (1) $thin_slr->lexer_progress_report_finish(); return $result; } ## end sub progress_report sub show_dotted_irl { my ( $self, $irl_id, $dot_position ) = @_; my $grammar_c = $self->{g}; my $lhs_id = $grammar_c->_marpa_g_irl_lhs($irl_id); my $irl_length = $grammar_c->_marpa_g_irl_length($irl_id); my $text = $self->isy_name($lhs_id) . q{ ::=}; if ( $dot_position < 0 ) { $dot_position = $irl_length; } my @rhs_names = (); for my $ix ( 0 .. $irl_length - 1 ) { my $rhs_nsy_id = $grammar_c->_marpa_g_irl_rhs( $irl_id, $ix ); my $rhs_nsy_name = $self->isy_name($rhs_nsy_id); push @rhs_names, $rhs_nsy_name; } POSITION: for my $position ( 0 .. scalar @rhs_names ) { if ( $position == $dot_position ) { $text .= q{ .}; } my $name = $rhs_names[$position]; next POSITION if not defined $name; $text .= " $name"; } ## end POSITION: for my $position ( 0 .. scalar @rhs_names ) return $text; } ## end sub show_dotted_irl sub show_ahm { my ( $self, $item_id ) = @_; my $grammar_c = $self->{g}; my $postdot_id = $grammar_c->_marpa_g_ahm_postdot($item_id); my $text = "AHM $item_id: "; my @properties = (); if ( $postdot_id < 0 ) { push @properties, 'completion'; } else { my $postdot_symbol_name = $self->isy_name($postdot_id); push @properties, qq{postdot = "$postdot_symbol_name"}; } $text .= join q{; }, @properties; $text .= "\n" . ( q{ } x 4 ); $text .= $self->show_brief_ahm($item_id) . "\n"; return $text; } ## end sub show_ahm sub show_brief_ahm { my ( $self, $item_id ) = @_; my $grammar_c = $self->{g}; my $postdot_id = $grammar_c->_marpa_g_ahm_postdot($item_id); my $irl_id = $grammar_c->_marpa_g_ahm_irl($item_id); my $position = $grammar_c->_marpa_g_ahm_position($item_id); return $self->show_dotted_irl( $irl_id, $position ); } ## end sub show_brief_ahm sub show_ahms { my ($self) = @_; my $grammar_c = $self->{g}; my $text = q{}; my $count = $grammar_c->_marpa_g_ahm_count(); for my $AHFA_item_id ( 0 .. $count - 1 ) { $text .= $self->show_ahm($AHFA_item_id); } return $text; } ## end sub show_ahms sub isy_name { my ( $self, $id ) = @_; my $grammar_c = $self->{g}; # The next is a little roundabout to prevent auto-instantiation my $name = '[ISY' . $id . ']'; GEN_NAME: { if ( $grammar_c->_marpa_g_nsy_is_start($id) ) { my $source_id = $grammar_c->_marpa_g_source_xsy($id); $name = $self->symbol_name($source_id); $name .= q<[']>; last GEN_NAME; } ## end if ( $grammar_c->_marpa_g_nsy_is_start($id) ) my $lhs_xrl = $grammar_c->_marpa_g_nsy_lhs_xrl($id); if ( defined $lhs_xrl and defined $grammar_c->sequence_min($lhs_xrl) ) { my $original_lhs_id = $grammar_c->rule_lhs($lhs_xrl); $name = $self->symbol_name($original_lhs_id) . '[Seq]'; last GEN_NAME; } ## end if ( defined $lhs_xrl and defined $grammar_c->sequence_min...) my $xrl_offset = $grammar_c->_marpa_g_nsy_xrl_offset($id); if ($xrl_offset) { my $original_lhs_id = $grammar_c->rule_lhs($lhs_xrl); $name = $self->symbol_name($original_lhs_id) . '[R' . $lhs_xrl . q{:} . $xrl_offset . ']'; last GEN_NAME; } ## end if ($xrl_offset) my $source_id = $grammar_c->_marpa_g_source_xsy($id); $name = $self->symbol_name($source_id); $name .= '[]' if $grammar_c->_marpa_g_nsy_is_nulling($id); } ## end GEN_NAME: return $name; } ## end sub isy_name sub show_rule { my ( $self, $rule_id ) = @_; my $grammar = $self->{g}; my @comment = (); $grammar->rule_length($rule_id) == 0 and push @comment, 'empty'; $grammar->rule_is_productive($rule_id) or push @comment, 'unproductive'; $grammar->rule_is_accessible($rule_id) or push @comment, 'inaccessible'; my $text = $self->brief_rule($rule_id); if (@comment) { $text .= q{ } . ( join q{ }, q{/*}, @comment, q{*/} ); } return $text .= "\n"; } # sub show_rule sub show_rules { my ($self) = @_; my $grammar = $self->{g}; my $text; my $highest_rule_id = $grammar->highest_rule_id(); RULE: for ( my $rule_id = 0; $rule_id <= $highest_rule_id; $rule_id++ ) { $text .= $self->show_rule($rule_id); } return $text; } ## end sub show_rules 1; Marpa-R2-2.086000~dfsg/lib/Marpa/R2/Internal.pm0000444000000000000000000001436612342464706017255 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # DO NOT EDIT THIS FILE DIRECTLY # It was generated by make_internal_pm.pl package Marpa::R2::Internal; use 5.010; use strict; use warnings; use Carp; use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; $VERSION = eval $VERSION; package Marpa::R2::Internal::Symbol; use constant ID => 0; use constant BLESSING => 1; use constant LEXEME_SEMANTICS => 2; use constant DISPLAY_FORM => 3; use constant DSL_FORM => 4; use constant LEGACY_NAME => 5; use constant DESCRIPTION => 6; use constant IF_INACCESSIBLE => 7; package Marpa::R2::Internal::Rule; use constant ID => 0; use constant NAME => 1; use constant DISCARD_SEPARATION => 2; use constant MASK => 3; use constant ACTION_NAME => 4; use constant BLESSING => 5; use constant DESCRIPTION => 6; package Marpa::R2::Internal::Grammar; use constant C => 0; use constant TRACER => 1; use constant RULES => 2; use constant DESCRIPTION_BY_RULE => 3; use constant SYMBOLS => 4; use constant ACTIONS => 5; use constant BLESS_PACKAGE => 6; use constant DEFAULT_ACTION => 7; use constant TRACE_FILE_HANDLE => 8; use constant WARNINGS => 9; use constant INTERFACE => 10; use constant INTERNAL => 11; use constant CHARACTER_CLASSES => 12; use constant CHARACTER_CLASS_TABLE => 13; use constant LAST_BASIC_DATA_FIELD => 13; use constant DEFAULT_EMPTY_ACTION => 14; use constant ACTION_OBJECT => 15; use constant INFINITE_ACTION => 16; use constant LAST_EVALUATOR_FIELD => 16; use constant PROBLEMS => 17; use constant LAST_RECOGNIZER_FIELD => 17; use constant START_NAME => 18; use constant INACCESSIBLE_OK => 19; use constant UNPRODUCTIVE_OK => 20; use constant TRACE_RULES => 21; use constant LAST_FIELD => 21; package Marpa::R2::Internal::Recognizer; use constant C => 0; use constant B_C => 1; use constant O_C => 2; use constant T_C => 3; use constant GRAMMAR => 4; use constant TREE_MODE => 5; use constant FINISHED => 6; use constant TOKEN_VALUES => 7; use constant ASF_OR_NODES => 8; use constant TRACE_FILE_HANDLE => 9; use constant ERROR_MESSAGE => 10; use constant END_OF_PARSE => 11; use constant CLOSURES => 12; use constant EVENT_IF_EXPECTED => 13; use constant MAX_PARSES => 14; use constant RANKING_METHOD => 15; use constant TRACE_ACTIONS => 16; use constant TRACE_AND_NODES => 17; use constant TRACE_BOCAGE => 18; use constant TRACE_EARLEY_SETS => 19; use constant TRACE_OR_NODES => 20; use constant TRACE_TERMINALS => 21; use constant TRACE_VALUES => 22; use constant TRACE_SL => 23; use constant WARNINGS => 24; use constant EVENTS => 25; use constant NO_PARSE => 26; use constant READ_STRING_ERROR => 27; use constant NULL_VALUES => 28; use constant PER_PARSE_CONSTRUCTOR => 29; use constant RESOLVE_PACKAGE => 30; use constant RESOLVE_PACKAGE_SOURCE => 31; use constant REGISTRATIONS => 32; use constant CLOSURE_BY_SYMBOL_ID => 33; use constant CLOSURE_BY_RULE_ID => 34; package Marpa::R2::Internal::Progress_Report; use constant RULE_ID => 0; use constant POSITION => 1; use constant ORIGIN => 2; use constant CURRENT => 3; package Marpa::R2::Internal::Glade; use constant ID => 0; use constant SYMCHES => 1; use constant VISITED => 2; use constant REGISTERED => 3; package Marpa::R2::Internal::Choicepoint; use constant ASF => 0; use constant FACTORING_STACK => 1; use constant OR_NODE_IN_USE => 2; package Marpa::R2::Internal::Nook; use constant PARENT => 0; use constant OR_NODE => 1; use constant FIRST_CHOICE => 2; use constant LAST_CHOICE => 3; use constant IS_CAUSE => 4; use constant IS_PREDECESSOR => 5; use constant CAUSE_IS_EXPANDED => 6; use constant PREDECESSOR_IS_EXPANDED => 7; package Marpa::R2::Internal::ASF; use constant SLR => 0; use constant LEXEME_RESOLUTIONS => 1; use constant RULE_RESOLUTIONS => 2; use constant FACTORING_MAX => 3; use constant RULE_BLESSINGS => 4; use constant SYMBOL_BLESSINGS => 5; use constant SYMCH_BLESSING_PACKAGE => 6; use constant FACTORING_BLESSING_PACKAGE => 7; use constant PROBLEM_BLESSING_PACKAGE => 8; use constant DEFAULT_RULE_BLESSING_PACKAGE => 9; use constant DEFAULT_TOKEN_BLESSING_PACKAGE => 10; use constant OR_NODES => 11; use constant GLADES => 12; use constant INTSET_BY_KEY => 13; use constant NEXT_INTSET_ID => 14; use constant NIDSET_BY_ID => 15; use constant POWERSET_BY_ID => 16; package Marpa::R2::Internal::ASF::Traverse; use constant ASF => 0; use constant VALUES => 1; use constant CODE => 2; use constant PER_TRAVERSE_OBJECT => 3; use constant GLADE => 4; use constant SYMCH_IX => 5; use constant FACTORING_IX => 6; package Marpa::R2::Internal::Nidset; use constant ID => 0; use constant NIDS => 1; package Marpa::R2::Internal::Powerset; use constant ID => 0; use constant NIDSET_IDS => 1; package Marpa::R2::Internal::Scanless::G; use constant C => 0; use constant THICK_LEX_GRAMMARS => 1; use constant THICK_G1_GRAMMAR => 2; use constant CHARACTER_CLASS_TABLES => 3; use constant LEXER_BY_NAME => 4; use constant LEXER_NAME_BY_ID => 5; use constant MASK_BY_RULE_ID => 6; use constant DEFAULT_G1_START_ACTION => 7; use constant COMPLETION_EVENT_BY_ID => 8; use constant NULLED_EVENT_BY_ID => 9; use constant PREDICTION_EVENT_BY_ID => 10; use constant LEXEME_EVENT_BY_ID => 11; use constant SYMBOL_IDS_BY_EVENT_NAME_AND_TYPE => 12; use constant CACHE_RULEIDS_BY_LHS_NAME => 13; use constant TRACE_FILE_HANDLE => 14; use constant TRACE_TERMINALS => 15; package Marpa::R2::Internal::Scanless::R; use constant C => 0; use constant GRAMMAR => 1; use constant THICK_G1_RECCE => 2; use constant P_INPUT_STRING => 3; use constant TRACE_FILE_HANDLE => 4; use constant TRACE_LEXERS => 5; use constant TRACE_TERMINALS => 6; use constant READ_STRING_ERROR => 7; use constant EVENTS => 8; 1; Marpa-R2-2.086000~dfsg/lib/Marpa/R2/Recognizer.pm0000444000000000000000000012764012342464707017611 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. package Marpa::R2::Recognizer; use 5.010; use warnings; use strict; use English qw( -no_match_vars ); use vars qw($VERSION $STRING_VERSION); $VERSION = '2.086000'; $STRING_VERSION = $VERSION; ## no critic(BuiltinFunctions::ProhibitStringyEval) $VERSION = eval $VERSION; ## use critic package Marpa::R2::Internal::Recognizer; use English qw( -no_match_vars ); my $parse_number = 0; # Returns the new parse object or throws an exception sub Marpa::R2::Recognizer::new { my ( $class, @arg_hashes ) = @_; my $recce = bless [], $class; my $grammar; my $trace_file_handle; for my $arg_hash (@arg_hashes) { # Need to capture the trace file handle early my $value; if ( defined( $value = $arg_hash->{trace_file_handle} ) ) { delete $arg_hash->{trace_file_handle}; $trace_file_handle = $value; } if ( defined( $value = $arg_hash->{grammar} ) ) { delete $arg_hash->{grammar}; $grammar = $value; } } ## end for my $arg_hash (@arg_hashes) Marpa::R2::exception('No grammar specified') if not defined $grammar; $trace_file_handle //= $grammar->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE] ; local $Marpa::R2::Internal::TRACE_FH = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE] = $trace_file_handle; $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR] = $grammar; my $grammar_class = ref $grammar; Marpa::R2::exception( "${class}::new() grammar arg has wrong class: $grammar_class") if not $grammar_class eq 'Marpa::R2::Grammar'; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $problems = $grammar->[Marpa::R2::Internal::Grammar::PROBLEMS]; if ($problems) { Marpa::R2::exception( Marpa::R2::Grammar::show_problems($grammar), "Attempt to parse grammar with fatal problems\n", 'Marpa::R2 cannot proceed', ); } ## end if ($problems) my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C] = Marpa::R2::Thin::R->new($grammar_c); if ( not defined $recce_c ) { my $error_code = $grammar_c->error_code() // -1; if ( $error_code == $Marpa::R2::Error::NOT_PRECOMPUTED ) { Marpa::R2::exception( 'Attempt to parse grammar which is not precomputed'); } Marpa::R2::exception( $grammar_c->error() ); } ## end if ( not defined $recce_c ) $recce_c->ruby_slippers_set(1); if ( defined $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT] or defined $grammar->[Marpa::R2::Internal::Grammar::ACTIONS] or not defined $grammar->[Marpa::R2::Internal::Grammar::INTERNAL] ) { $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE] = 'legacy'; } ## end if ( defined $grammar->[...]) ARG_HASH: for my $arg_hash (@arg_hashes) { if ( defined( my $value = $arg_hash->{'leo'} ) ) { my $boolean = $value ? 1 : 0; $recce->use_leo_set($boolean); delete $arg_hash->{leo}; } } ## end ARG_HASH: for my $arg_hash (@arg_hashes) ARG_HASH: for my $arg_hash (@arg_hashes) { if ( defined( my $value = $arg_hash->{'event_if_expected'} ) ) { Marpa::R2::exception( 'value of "event_if_expected" must be a REF to an array of symbol names' ) if ref $value ne 'ARRAY'; for my $symbol_name ( @{$value} ) { my $symbol_id = $tracer->symbol_by_name($symbol_name); Marpa::exception( qq{Unknown symbol in "event_if_expected" value: "$symbol_name"} ) if not defined $symbol_id; $recce_c->expected_symbol_event_set( $symbol_id, 1 ); } ## end for my $symbol_name ( @{$value} ) delete $arg_hash->{event_if_expected}; } ## end if ( defined( my $value = $arg_hash->{'event_if_expected'...})) } ## end ARG_HASH: for my $arg_hash (@arg_hashes) $recce->[Marpa::R2::Internal::Recognizer::WARNINGS] = 1; $recce->[Marpa::R2::Internal::Recognizer::RANKING_METHOD] = 'none'; $recce->[Marpa::R2::Internal::Recognizer::MAX_PARSES] = 0; # Position 0 is not used because 0 indicates an unvalued token. # Position 1 is reserved for undef. # Position 2 is reserved for literal tokens (used in SLIF). $recce->[Marpa::R2::Internal::Recognizer::TOKEN_VALUES] = [undef, undef, undef]; $recce->reset_evaluation(); if ( not $recce_c->start_input() ) { my $error = $grammar_c->error(); Marpa::R2::exception( 'Recognizer start of input failed: ', $error ); } $recce->[Marpa::R2::Internal::Recognizer::EVENTS] = cook_events($recce); $recce->set(@arg_hashes); my $trace_terminals = $recce->[Marpa::R2::Internal::Recognizer::TRACE_TERMINALS] // 0; if ( $trace_terminals > 1 ) { my @terminals_expected = @{ $recce->terminals_expected() }; for my $terminal ( sort @terminals_expected ) { say {$Marpa::R2::Internal::TRACE_FH} qq{Expecting "$terminal" at earleme 0} or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( $trace_terminals > 1 ) return $recce; } ## end sub Marpa::R2::Recognizer::new # Not documented, at least for the moment sub Marpa::R2::Recognizer::grammar { $_[0]->[Marpa::R2::Internal::Recognizer::GRAMMAR]; } sub Marpa::R2::Recognizer::thin { $_[0]->[Marpa::R2::Internal::Recognizer::C]; } sub Marpa::R2::Recognizer::reset_evaluation { my ($recce) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $package_source = $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE]; if ( defined $package_source and $package_source ne 'legacy' ) { # Packaage source, once legacy, stays legacy # Otherwise, reset it $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE] = undef; } ## end if ( defined $package_source and $package_source ne ...) $recce->[Marpa::R2::Internal::Recognizer::NO_PARSE] = undef; $recce->[Marpa::R2::Internal::Recognizer::ASF_OR_NODES] = []; $recce->[Marpa::R2::Internal::Recognizer::B_C] = undef; $recce->[Marpa::R2::Internal::Recognizer::EVENTS] = []; $recce->[Marpa::R2::Internal::Recognizer::O_C] = undef; $recce->[Marpa::R2::Internal::Recognizer::PER_PARSE_CONSTRUCTOR] = undef; $recce->[Marpa::R2::Internal::Recognizer::READ_STRING_ERROR] = undef; $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE] = undef; $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES] = undef; $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] = undef; $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_SYMBOL_ID] = undef; $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_RULE_ID] = undef; $recce->[Marpa::R2::Internal::Recognizer::T_C] = undef; $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE] = undef; return; } ## end sub Marpa::R2::Recognizer::reset_evaluation sub Marpa::R2::Recognizer::set { my ( $recce, @arg_hashes ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; # This may get changed below my $trace_fh = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE]; for my $args (@arg_hashes) { my $ref_type = ref $args; if ( not $ref_type or $ref_type ne 'HASH' ) { Carp::croak( 'Marpa::R2 Recognizer expects args as ref to HASH, got ', ( "ref to $ref_type" || 'non-reference' ), ' instead' ); } ## end if ( not $ref_type or $ref_type ne 'HASH' ) state $recognizer_options = { map { ( $_, 1 ) } qw( closures end event_if_expected leo max_parses semantics_package ranking_method too_many_earley_items trace_actions trace_and_nodes trace_bocage trace_earley_sets trace_fh trace_file_handle trace_or_nodes trace_terminals trace_values warnings ) }; if (my @bad_options = grep { not exists $recognizer_options->{$_} } keys %{$args} ) { Carp::croak( 'Unknown option(s) for Marpa::R2 Recognizer: ', join q{ }, @bad_options ); } ## end if ( my @bad_options = grep { not exists $recognizer_options...}) if ( defined( my $value = $args->{'event_if_expected'} ) ) { ## It could be allowed, but it is not needed and this is simpler Marpa::R2::exception( q{'event_if_expected' not allowed once input has started}); } if ( defined( my $value = $args->{'leo'} ) ) { Marpa::R2::exception( q{Cannot reset 'leo' once input has started}); } if ( defined( my $value = $args->{'max_parses'} ) ) { $recce->[Marpa::R2::Internal::Recognizer::MAX_PARSES] = $value; } if ( defined( my $value = $args->{'semantics_package'} ) ) { # Not allowed once parsing is started if ( defined $recce->[Marpa::R2::Internal::Recognizer::B_C] ) { Marpa::R2::exception( q{Cannot change 'semantics_package' named argument once parsing has started} ); } $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE] //= 'semantics_package'; if ( $recce ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE] ne 'semantics_package' ) { Marpa::R2::exception( qq{'semantics_package' named argument in conflict with other choices\n}, qq{ Usually this means you tried to use the discouraged 'action_object' named argument as well\n} ); } ## end if ( $recce->[...]) $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE] = $value; } ## end if ( defined( my $value = $args->{'semantics_package'...})) if ( defined( my $value = $args->{'ranking_method'} ) ) { # Not allowed once parsing is started if ( defined $recce->[Marpa::R2::Internal::Recognizer::B_C] ) { Marpa::R2::exception( q{Cannot change ranking method once parsing has started}); } state $ranking_methods = { map { ($_, 0) } qw(high_rule_only rule none) }; Marpa::R2::exception( qq{ranking_method value is $value (should be one of }, ( join q{, }, map { q{'} . $_ . q{'} } keys %{$ranking_methods} ), ')' ) if not exists $ranking_methods->{$value}; $recce->[Marpa::R2::Internal::Recognizer::RANKING_METHOD] = $value; } ## end if ( defined( my $value = $args->{'ranking_method'} ...)) if ( defined( my $value = $args->{'trace_fh'} ) ) { $trace_fh = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE] = $value; } if ( defined( my $value = $args->{'trace_file_handle'} ) ) { $trace_fh = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE] = $value; } if ( defined( my $value = $args->{'trace_actions'} ) ) { $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] = $value; if ($value) { say {$trace_fh} 'Setting trace_actions option' or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( defined( my $value = $args->{'trace_actions'} )) if ( defined( my $value = $args->{'trace_and_nodes'} ) ) { Marpa::R2::exception( 'trace_and_nodes must be set to a number >= 0') if $value !~ /\A\d+\z/xms; $recce->[Marpa::R2::Internal::Recognizer::TRACE_AND_NODES] = $value + 0; if ($value) { say {$trace_fh} "Setting trace_and_nodes option to $value" or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( defined( my $value = $args->{'trace_and_nodes'}...)) if ( defined( my $value = $args->{'trace_bocage'} ) ) { Marpa::R2::exception('trace_bocage must be set to a number >= 0') if $value !~ /\A\d+\z/xms; $recce->[Marpa::R2::Internal::Recognizer::TRACE_BOCAGE] = $value + 0; if ($value) { say {$trace_fh} "Setting trace_bocage option to $value" or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( defined( my $value = $args->{'trace_bocage'} ) ) if ( defined( my $value = $args->{'trace_or_nodes'} ) ) { Marpa::R2::exception( 'trace_or_nodes must be set to a number >= 0') if $value !~ /\A\d+\z/xms; $recce->[Marpa::R2::Internal::Recognizer::TRACE_OR_NODES] = $value + 0; if ($value) { say {$trace_fh} "Setting trace_or_nodes option to $value" or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( defined( my $value = $args->{'trace_or_nodes'} ...)) if ( defined( my $value = $args->{'trace_terminals'} ) ) { $recce->[Marpa::R2::Internal::Recognizer::TRACE_TERMINALS] = $value; if ($value) { say {$trace_fh} 'Setting trace_terminals option' or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( defined( my $value = $args->{'trace_terminals'}...)) if ( defined( my $value = $args->{'trace_earley_sets'} ) ) { $recce->[Marpa::R2::Internal::Recognizer::TRACE_EARLEY_SETS] = $value; if ($value) { say {$trace_fh} 'Setting trace_earley_sets option' or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( defined( my $value = $args->{'trace_earley_sets'...})) if ( defined( my $value = $args->{'trace_values'} ) ) { $recce->[Marpa::R2::Internal::Recognizer::TRACE_VALUES] = $value; if ($value) { say {$trace_fh} 'Setting trace_values option' or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( defined( my $value = $args->{'trace_values'} ) ) if ( defined( my $value = $args->{'end'} ) ) { # Not allowed once evaluation is started if ( defined $recce->[Marpa::R2::Internal::Recognizer::B_C] ) { Marpa::R2::exception( q{Cannot reset end once evaluation has started}); } $recce->[Marpa::R2::Internal::Recognizer::END_OF_PARSE] = $value; } ## end if ( defined( my $value = $args->{'end'} ) ) if ( defined( my $value = $args->{'closures'} ) ) { # Not allowed once evaluation is started if ( defined $recce->[Marpa::R2::Internal::Recognizer::B_C] ) { Marpa::R2::exception( q{Cannot reset closures once evaluation has started}); } my $closures = $recce->[Marpa::R2::Internal::Recognizer::CLOSURES] = $value; for my $action ( keys %{$closures} ) { my $closure = $closures->{$action}; Marpa::R2::exception(qq{Bad closure for action "$action"}) if ref $closure ne 'CODE'; } } ## end if ( defined( my $value = $args->{'closures'} ) ) if ( defined( my $value = $args->{'warnings'} ) ) { $recce->[Marpa::R2::Internal::Recognizer::WARNINGS] = $value; } if ( defined( my $value = $args->{'too_many_earley_items'} ) ) { $recce_c->earley_item_warning_threshold_set($value); } } ## end for my $args (@arg_hashes) return 1; } ## end sub Marpa::R2::Recognizer::set sub Marpa::R2::Recognizer::latest_earley_set { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; return $recce_c->latest_earley_set(); } sub Marpa::R2::Recognizer::check_terminal { my ( $recce, $name ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; return $grammar->check_terminal($name); } sub Marpa::R2::Recognizer::exhausted { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; return $recce_c->is_exhausted(); } sub Marpa::R2::Recognizer::current_earleme { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; return $recce_c->current_earleme(); } sub Marpa::R2::Recognizer::furthest_earleme { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; return $recce_c->furthest_earleme(); } sub Marpa::R2::Recognizer::earleme { my ( $recce, $earley_set_id ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; return $recce_c->earleme($earley_set_id); } sub Marpa::R2::Recognizer::expected_symbol_event_set { my ( $recce, $symbol_name, $value ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $symbol_id = $grammar->[Marpa::R2::Internal::Grammar::TRACER] ->symbol_by_name($symbol_name); Marpa::exception(qq{Unknown symbol: "$symbol_name"}) if not defined $symbol_id; return $recce_c->expected_symbol_event_set( $symbol_id, $value ); } ## end sub Marpa::R2::Recognizer::expected_symbol_event_set # Now useless and deprecated sub Marpa::R2::Recognizer::strip { return 1; } # Viewing methods, for debugging sub Marpa::R2::Recognizer::progress { my ( $recce, $ordinal_arg ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $latest_earley_set = $recce->latest_earley_set(); my $ordinal; SET_ORDINAL: { if ( not defined $ordinal_arg ) { $ordinal = $latest_earley_set; last SET_ORDINAL; } if ( $ordinal_arg > $latest_earley_set ) { Marpa::R2::exception( qq{Argument out of bounds in recce->progress($ordinal_arg)\n}, qq{ Argument specifies Earley set after the latest Earley set 0\n}, qq{ The latest Earley set is Earley set $latest_earley_set\n} ); } ## end if ( $ordinal_arg > $latest_earley_set ) if ( $ordinal_arg >= 0 ) { $ordinal = $ordinal_arg; last SET_ORDINAL; } # If we are here, $ordinal_arg < 0 $ordinal = $latest_earley_set + 1 + $ordinal_arg; Marpa::R2::exception( qq{Argument out of bounds in recce->progress($ordinal_arg)\n}, qq{ Argument specifies Earley set before Earley set 0\n} ) if $ordinal < 0; } ## end SET_ORDINAL: my $result = []; $recce_c->progress_report_start($ordinal); ITEM: while (1) { my @item = $recce_c->progress_item(); last ITEM if not defined $item[0]; push @{$result}, [@item]; } $recce_c->progress_report_finish(); return $result; } ## end sub Marpa::R2::Recognizer::progress sub Marpa::R2::Recognizer::show_progress { my ( $recce, $start_ordinal, $end_ordinal ) = @_; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $last_ordinal = $recce->latest_earley_set(); if ( not defined $start_ordinal ) { $start_ordinal = $last_ordinal; } if ( $start_ordinal < 0 ) { $start_ordinal += $last_ordinal + 1; } else { if ( $start_ordinal < 0 or $start_ordinal > $last_ordinal ) { return "Marpa::PP::Recognizer::show_progress start index is $start_ordinal, " . "must be in range 0-$last_ordinal"; } } ## end else [ if ( $start_ordinal < 0 ) ] if ( not defined $end_ordinal ) { $end_ordinal = $start_ordinal; } else { my $end_ordinal_argument = $end_ordinal; if ( $end_ordinal < 0 ) { $end_ordinal += $last_ordinal + 1; } if ( $end_ordinal < 0 ) { return "Marpa::PP::Recognizer::show_progress end index is $end_ordinal_argument, " . sprintf ' must be in range %d-%d', -( $last_ordinal + 1 ), $last_ordinal; } ## end if ( $end_ordinal < 0 ) } ## end else [ if ( not defined $end_ordinal ) ] my $text = q{}; for my $current_ordinal ( $start_ordinal .. $end_ordinal ) { my $current_earleme = $recce->earleme($current_ordinal); my %by_rule_by_position = (); for my $progress_item ( @{ $recce->progress($current_ordinal) } ) { my ( $rule_id, $position, $origin ) = @{$progress_item}; if ( $position < 0 ) { $position = $grammar_c->rule_length($rule_id); } $by_rule_by_position{$rule_id}->{$position}->{$origin}++; } ## end for my $progress_item ( @{ $recce->progress($current_ordinal...)}) for my $rule_id ( sort { $a <=> $b } keys %by_rule_by_position ) { my $by_position = $by_rule_by_position{$rule_id}; for my $position ( sort { $a <=> $b } keys %{$by_position} ) { my $raw_origins = $by_position->{$position}; my @origins = sort { $a <=> $b } keys %{$raw_origins}; my $origins_count = scalar @origins; my $origin_desc; if ( $origins_count <= 3 ) { $origin_desc = join q{,}, @origins; } else { $origin_desc = $origins[0] . q{...} . $origins[-1]; } my $rhs_length = $grammar_c->rule_length($rule_id); my $item_text; # flag indicating whether we need to show the dot in the rule if ( $position >= $rhs_length ) { $item_text .= "F$rule_id"; } elsif ($position) { $item_text .= "R$rule_id:$position"; } else { $item_text .= "P$rule_id"; } $item_text .= " x$origins_count" if $origins_count > 1; $item_text .= q{ @} . $origin_desc . q{-} . $current_earleme . q{ }; $item_text .= $grammar->show_dotted_rule( $rule_id, $position ); $text .= $item_text . "\n"; } ## end for my $position ( sort { $a <=> $b } keys %{...}) } ## end for my $rule_id ( sort { $a <=> $b } keys ...) } ## end for my $current_ordinal ( $start_ordinal .. $end_ordinal) return $text; } ## end sub Marpa::R2::Recognizer::show_progress sub Marpa::R2::Recognizer::read { my $arg_count = scalar @_; my ( $recce, $symbol_name, $value ) = @_; return if not $recce->alternative( $symbol_name, \$value ); return $recce->earleme_complete(); } ## end sub Marpa::R2::Recognizer::read sub Marpa::R2::Recognizer::alternative { my ( $recce, $symbol_name, $value_ref, $length ) = @_; Marpa::R2::exception( 'No recognizer object for Marpa::R2::Recognizer::tokens') if not defined $recce or ref $recce ne 'Marpa::R2::Recognizer'; Marpa::R2::exception( "recce->alternative(): symbol name is undefined\n", " The symbol name cannot be undefined\n" ) if not defined $symbol_name; Marpa::R2::exception('Attempt to read token after parsing is finished') if $recce->[Marpa::R2::Internal::Recognizer::FINISHED]; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $trace_fh = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $token_values = $recce->[Marpa::R2::Internal::Recognizer::TOKEN_VALUES]; my $symbol_id = $grammar->[Marpa::R2::Internal::Grammar::TRACER] ->symbol_by_name($symbol_name); if ( not defined $symbol_id ) { Marpa::R2::exception( qq{alternative(): symbol "$symbol_name" does not exist}); } my $value_ix = 1; # undef SET_VALUE_IX: { last SET_VALUE_IX if not defined $value_ref; my $ref_type = ref $value_ref; if ( $ref_type ne 'SCALAR' and $ref_type ne 'REF' and $ref_type ne 'VSTRING' ) { Marpa::R2::exception('alternative(): value must be undef or ref'); } ## end if ( $ref_type ne 'SCALAR' and $ref_type ne 'REF' and...) my $value = ${$value_ref}; last SET_VALUE_IX if not defined $value; $value_ix = scalar @{$token_values}; push @{$token_values}, $value; } ## end SET_VALUE_IX: $length //= 1; # value_ix is *never* zero. my $result = $recce_c->alternative( $symbol_id, $value_ix, $length ); my $trace_terminals = $recce->[Marpa::R2::Internal::Recognizer::TRACE_TERMINALS]; if ($trace_terminals) { my $verb = $result == $Marpa::R2::Error::NONE ? 'Accepted' : 'Rejected'; my $current_earleme = $recce_c->current_earleme(); say {$trace_fh} qq{$verb "$symbol_name" at $current_earleme-} . ( $length + $current_earleme ) or Marpa::R2::exception("Cannot print: $ERRNO"); } ## end if ($trace_terminals) return 1 if $result == $Marpa::R2::Error::NONE; # The last two are perhaps unnecessary or arguable, # but they preserve compatibility with Marpa::XS return if $result == $Marpa::R2::Error::UNEXPECTED_TOKEN_ID || $result == $Marpa::R2::Error::NO_TOKEN_EXPECTED_HERE || $result == $Marpa::R2::Error::INACCESSIBLE_TOKEN; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; Marpa::R2::exception( $grammar_c->error() ); } ## end sub Marpa::R2::Recognizer::alternative # Perform the completion step on an earley set sub Marpa::R2::Recognizer::end_input { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $furthest_earleme = $recce_c->furthest_earleme(); while ( $recce_c->current_earleme() < $furthest_earleme ) { $recce->earleme_complete(); } $recce->[Marpa::R2::Internal::Recognizer::FINISHED] = 1; return 1; } ## end sub Marpa::R2::Recognizer::end_input sub Marpa::R2::Recognizer::terminals_expected { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; return [ map { $grammar->symbol_name($_) } $recce_c->terminals_expected() ]; } ## end sub Marpa::R2::Recognizer::terminals_expected sub cook_events { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my @cooked_events = (); my $event_count = $grammar_c->event_count(); EVENT: for ( my $event_ix = 0; $event_ix < $event_count; $event_ix++ ) { my ( $event_type, $value ) = $grammar_c->event($event_ix); if ( $event_type eq 'MARPA_EVENT_EARLEY_ITEM_THRESHOLD' ) { say { $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE] } "Earley item count ($value) exceeds warning threshold" or die "say: $ERRNO"; push @cooked_events, ['EARLEY_ITEM_THRESHOLD']; next EVENT; } ## end if ( $event_type eq 'MARPA_EVENT_EARLEY_ITEM_THRESHOLD') if ( $event_type eq 'MARPA_EVENT_SYMBOL_EXPECTED' ) { push @cooked_events, [ 'SYMBOL_EXPECTED', $grammar->symbol_name($value) ]; next EVENT; } if ( $event_type eq 'MARPA_EVENT_EXHAUSTED' ) { push @cooked_events, ['EXHAUSTED']; next EVENT; } } ## end EVENT: for ( my $event_ix = 0; $event_ix < $event_count; ...) return \@cooked_events; } ## end sub cook_events sub Marpa::R2::Recognizer::earleme_complete { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; local $Marpa::R2::Internal::TRACE_FH = $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $event_count = $recce_c->earleme_complete(); $recce->[Marpa::R2::Internal::Recognizer::EVENTS] = $event_count ? cook_events($recce) : []; if ( $recce->[Marpa::R2::Internal::Recognizer::TRACE_EARLEY_SETS] ) { my $latest_set = $recce_c->latest_earley_set(); print {$Marpa::R2::Internal::TRACE_FH} "=== Earley set $latest_set\n" or Marpa::R2::exception("Cannot print: $ERRNO"); print {$Marpa::R2::Internal::TRACE_FH} Marpa::R2::show_earley_set($latest_set) or Marpa::R2::exception("Cannot print: $ERRNO"); } ## end if ( $recce->[Marpa::R2::Internal::Recognizer::TRACE_EARLEY_SETS...]) my $trace_terminals = $recce->[Marpa::R2::Internal::Recognizer::TRACE_TERMINALS] // 0; if ( $trace_terminals > 1 ) { my $current_earleme = $recce_c->current_earleme(); my $terminals_expected = $recce->terminals_expected(); for my $terminal ( @{$terminals_expected} ) { say {$Marpa::R2::Internal::TRACE_FH} qq{Expecting "$terminal" at $current_earleme} or Marpa::R2::exception("Cannot print: $ERRNO"); } } ## end if ( $trace_terminals > 1 ) return $event_count; } ## end sub Marpa::R2::Recognizer::earleme_complete sub Marpa::R2::Recognizer::events { my ($recce) = @_; return $recce->[Marpa::R2::Internal::Recognizer::EVENTS]; } my @escape_by_ord = (); $escape_by_ord[ ord q{\\} ] = q{\\\\}; $escape_by_ord[ ord eval qq{"$_"} ] = $_ for "\\t", "\\r", "\\f", "\\b", "\\a", "\\e"; $escape_by_ord[0xa] = '\\n'; $escape_by_ord[$_] //= chr $_ for 32 .. 126; $escape_by_ord[$_] //= sprintf( "\\x%02x", $_ ) for 0 .. 255; sub Marpa::R2::escape_string { my ( $string, $length ) = @_; my $reversed = $length < 0; if ($reversed) { $string = reverse $string; $length = -$length; } my @escaped_chars = (); ORD: for my $ord ( map {ord} split //xms, $string ) { last ORD if $length <= 0; my $escaped_char = $escape_by_ord[$ord] // sprintf( "\\x{%04x}", $ord ); $length -= length $escaped_char; push @escaped_chars, $escaped_char; } ## end for my $ord ( map {ord} split //xms, $string ) @escaped_chars = reverse @escaped_chars if $reversed; IX: for my $ix ( reverse 0 .. $#escaped_chars ) { # only trailing spaces are escaped last IX if $escaped_chars[$ix] ne q{ }; $escaped_chars[$ix] = '\\s'; } ## end IX: for my $ix ( reverse 0 .. $#escaped_chars ) return join q{}, @escaped_chars; } ## end sub escape_string # INTERNAL OK AFTER HERE _marpa_ sub Marpa::R2::Recognizer::use_leo_set { my ( $recce, $boolean ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; return $recce_c->_marpa_r_is_use_leo_set($boolean); } # Not intended to be documented. # Returns the size of the last completed earley set. # For testing, especially that the Leo items # are doing their job. sub Marpa::R2::Recognizer::earley_set_size { my ( $recce, $set_id ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; $set_id //= $recce_c->latest_earley_set(); return $recce_c->_marpa_r_earley_set_size($set_id); } sub ahm_describe { my ($recce, $ahm_id) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $irl_id = $grammar_c->_marpa_g_ahm_irl($ahm_id); my $dot_position = $grammar_c->_marpa_g_ahm_position($ahm_id); if ($dot_position < 0) { return 'R' . $irl_id . q{$} } return 'R' . $irl_id . q{:} . $dot_position; } sub Marpa::R2::show_leo_item { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $leo_base_state = $recce_c->_marpa_r_leo_base_state(); return if not defined $leo_base_state; my $trace_earley_set = $recce_c->_marpa_r_trace_earley_set(); my $trace_earleme = $recce_c->earleme($trace_earley_set); my $postdot_symbol_id = $recce_c->_marpa_r_postdot_item_symbol(); my $postdot_symbol_name = $tracer->isy_name($postdot_symbol_id); my $predecessor_symbol_id = $recce_c->_marpa_r_leo_predecessor_symbol(); my $base_origin_set_id = $recce_c->_marpa_r_leo_base_origin(); my $base_origin_earleme = $recce_c->earleme($base_origin_set_id); my $text = sprintf 'L%d@%d', $postdot_symbol_id, $trace_earleme; my @link_texts = qq{"$postdot_symbol_name"}; if ( defined $predecessor_symbol_id ) { push @link_texts, sprintf 'L%d@%d', $predecessor_symbol_id, $base_origin_earleme; } push @link_texts, sprintf 'S%d@%d-%d', $leo_base_state, $base_origin_earleme, $trace_earleme; $text .= ' [' . ( join '; ', @link_texts ) . ']'; return $text; } ## end sub Marpa::R2::show_leo_item # Assumes trace token source link set by caller sub Marpa::R2::show_token_link_choice { my ( $recce, $current_earleme ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $text = q{}; my @pieces = (); my ( $token_id, $value_ix ) = $recce_c->_marpa_r_source_token(); my $predecessor_ahm = $recce_c->_marpa_r_source_predecessor_state(); my $origin_set_id = $recce_c->_marpa_r_earley_item_origin(); my $origin_earleme = $recce_c->earleme($origin_set_id); my $middle_earleme = $origin_earleme; if ( defined $predecessor_ahm ) { my $middle_set_id = $recce_c->_marpa_r_source_middle(); $middle_earleme = $recce_c->earleme($middle_set_id); push @pieces, 'c=' . ahm_describe($recce, $predecessor_ahm) . q{@} . $origin_earleme . q{-} . $middle_earleme; } ## end if ( defined $predecessor_ahm ) my $symbol_name = $tracer->isy_name($token_id); push @pieces, 's=' . $symbol_name; my $token_length = $current_earleme - $middle_earleme; my $value = $recce->[Marpa::R2::Internal::Recognizer::TOKEN_VALUES]->[$value_ix]; my $token_dump = Data::Dumper->new( [ \$value ] )->Terse(1)->Dump; chomp $token_dump; push @pieces, "t=$token_dump"; return '[' . ( join '; ', @pieces ) . ']'; } ## end sub Marpa::R2::show_token_link_choice # Assumes trace completion source link set by caller sub Marpa::R2::show_completion_link_choice { my ( $recce, $link_ahm_id, $current_earleme ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $text = q{}; my @pieces = (); my $predecessor_state = $recce_c->_marpa_r_source_predecessor_state(); my $origin_set_id = $recce_c->_marpa_r_earley_item_origin(); my $origin_earleme = $recce_c->earleme($origin_set_id); my $middle_set_id = $recce_c->_marpa_r_source_middle(); my $middle_earleme = $recce_c->earleme($middle_set_id); if ( defined $predecessor_state ) { push @pieces, 'p=' . ahm_describe($recce, $predecessor_state) . q{@} . $origin_earleme . q{-} . $middle_earleme; } ## end if ( defined $predecessor_state ) push @pieces, 'c=' . ahm_describe($recce, $link_ahm_id) . q{@} . $middle_earleme . q{-} . $current_earleme; return '[' . ( join '; ', @pieces ) . ']'; } ## end sub Marpa::R2::show_completion_link_choice # Assumes trace completion source link set by caller sub Marpa::R2::show_leo_link_choice { my ( $recce, $link_ahm_id, $current_earleme ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS]; my $text = q{}; my @pieces = (); my $middle_set_id = $recce_c->_marpa_r_source_middle(); my $middle_earleme = $recce_c->earleme($middle_set_id); my $leo_transition_symbol = $recce_c->_marpa_r_source_leo_transition_symbol(); push @pieces, 'l=L' . $leo_transition_symbol . q{@} . $middle_earleme; push @pieces, 'c=' . ahm_describe($recce, $link_ahm_id) . q{@} . $middle_earleme . q{-} . $current_earleme; return '[' . ( join '; ', @pieces ) . ']'; } ## end sub Marpa::R2::show_leo_link_choice # Assumes trace earley item was set by caller sub Marpa::R2::show_earley_item { my ( $recce, $current_es, $item_id ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER]; my $ahm_id_of_yim = $recce_c->_marpa_r_earley_item_trace($item_id); return if not defined $ahm_id_of_yim; my $text = q{}; my $origin_set_id = $recce_c->_marpa_r_earley_item_origin(); my $earleme = $recce_c->earleme($current_es); my $origin_earleme = $recce_c->earleme($origin_set_id); $text .= sprintf "ahm%d: %s@%d-%d", $ahm_id_of_yim, ahm_describe($recce, $ahm_id_of_yim), $origin_earleme, $earleme; my @lines = $text; my $irl_id = $grammar_c->_marpa_g_ahm_irl($ahm_id_of_yim); my $dot_position = $grammar_c->_marpa_g_ahm_position($ahm_id_of_yim); push @lines, qq{ } . ahm_describe($recce, $ahm_id_of_yim) . q{: } . $tracer->show_dotted_irl($irl_id, $dot_position); my @sort_data = (); for ( my $symbol_id = $recce_c->_marpa_r_first_token_link_trace(); defined $symbol_id; $symbol_id = $recce_c->_marpa_r_next_token_link_trace() ) { push @sort_data, [ $recce_c->_marpa_r_source_middle(), $symbol_id, ( $recce_c->_marpa_r_source_predecessor_state() // -1 ), Marpa::R2::show_token_link_choice( $recce, $earleme ) ]; } ## end for ( my $symbol_id = $recce_c->_marpa_r_first_token_link_trace...) my @pieces = map { $_->[-1] } sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } @sort_data; @sort_data = (); for ( my $cause_AHFA_id = $recce_c->_marpa_r_first_completion_link_trace(); defined $cause_AHFA_id; $cause_AHFA_id = $recce_c->_marpa_r_next_completion_link_trace() ) { push @sort_data, [ $recce_c->_marpa_r_source_middle(), $cause_AHFA_id, ( $recce_c->_marpa_r_source_predecessor_state() // -1 ), Marpa::R2::show_completion_link_choice( $recce, $cause_AHFA_id, $earleme ) ]; } ## end for ( my $cause_AHFA_id = $recce_c...) push @pieces, map { $_->[-1] } sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } @sort_data; @sort_data = (); for ( my $link_ahm_id = $recce_c->_marpa_r_first_leo_link_trace(); defined $link_ahm_id; $link_ahm_id = $recce_c->_marpa_r_next_leo_link_trace() ) { push @sort_data, [ $recce_c->_marpa_r_source_middle(), $link_ahm_id, $recce_c->_marpa_r_source_leo_transition_symbol(), Marpa::R2::show_leo_link_choice( $recce, $link_ahm_id, $earleme ) ]; } ## end for ( my $link_ahm_id = $recce_c...) push @pieces, map { $_->[-1] } sort { $a->[0] <=> $b->[0] || $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } @sort_data; push @lines, q{ } . join q{ }, @pieces if @pieces; return join "\n", @lines, q{}; } ## end sub Marpa::R2::show_earley_item sub Marpa::R2::show_earley_set { my ( $recce, $traced_set_id ) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $text = q{}; my @sorted_data = (); if ( not defined $recce_c->_marpa_r_earley_set_trace($traced_set_id) ) { return $text; } EARLEY_ITEM: for ( my $item_id = 0;; $item_id++ ) { my $item_desc = Marpa::R2::show_earley_item( $recce, $traced_set_id, $item_id ); last EARLEY_ITEM if not defined $item_desc; # We do not sort these any more push @sorted_data, $item_desc; } ## end EARLEY_ITEM: for ( my $item_id = 0;; $item_id++ ) my @sort_data = (); POSTDOT_ITEM: for ( my $postdot_symbol_id = $recce_c->_marpa_r_first_postdot_item_trace(); defined $postdot_symbol_id; $postdot_symbol_id = $recce_c->_marpa_r_next_postdot_item_trace() ) { # If there is no base Earley item, # then this is not a Leo item, so we skip it my $leo_item_desc = Marpa::R2::show_leo_item($recce); next POSTDOT_ITEM if not defined $leo_item_desc; push @sort_data, [ $postdot_symbol_id, $leo_item_desc ]; } ## end POSTDOT_ITEM: for ( my $postdot_symbol_id = $recce_c...) push @sorted_data, join q{}, map { $_->[-1] . "\n" } sort { $a->[0] <=> $b->[0] } @sort_data; return join q{}, @sorted_data; } ## end sub Marpa::R2::show_earley_set sub Marpa::R2::Recognizer::show_earley_sets { my ($recce) = @_; my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C]; my $last_completed_earleme = $recce_c->current_earleme(); my $furthest_earleme = $recce_c->furthest_earleme(); my $text = "Last Completed: $last_completed_earleme; " . "Furthest: $furthest_earleme\n"; LIST: for ( my $ix = 0;; $ix++ ) { my $set_desc = Marpa::R2::show_earley_set( $recce, $ix ); last LIST if not $set_desc; $text .= "Earley Set $ix\n$set_desc"; } return $text; } ## end sub Marpa::R2::Recognizer::show_earley_sets 1; # vim: set expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/lib/Marpa/R2/.gitignore0000444000000000000000000000003612342464706017120 0ustar rootroot/Version[.]pm /Installed[.]pm Marpa-R2-2.086000~dfsg/lib/Marpa/R2/meta/0000755000000000000000000000000012342464707016062 5ustar rootrootMarpa-R2-2.086000~dfsg/lib/Marpa/R2/meta/Makefile0000444000000000000000000000202512342464707017517 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. dummy: doit: -test -r metag-g3.pl && mv metag-g3.pl metag-g4.pl -test -r metag-g2.pl && mv metag-g2.pl metag-g3.pl -test -r metag-g1.pl && mv metag-g1.pl metag-g2.pl -mv metag.pl metag-g1.pl perl sl_to_hash.pl < metag.bnf > metag.pl bak: for f in metag*.pl; do cp $$f $$f.bak; done diff: diff metag.pl metag-g1.pl || true Marpa-R2-2.086000~dfsg/lib/Marpa/R2/meta/sl_to_hash.pl0000555000000000000000000000526212342464707020550 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Data::Dumper; # This is a 'meta' tool, so I relax some of the # restrictions I use to guarantee portability. use autodie; # I expect to be run from a subdirectory in the # development heirarchy use lib '../../../'; use lib '../../../../blib/arch'; use Marpa::R2; use Getopt::Long; my $verbose = 1; my $help_flag = 0; my $result = Getopt::Long::GetOptions( 'help' => \$help_flag, ); die "usage $PROGRAM_NAME [--help] file ...\n" if $help_flag; my $bnf = do { local $RS = undef; \(<>) }; my $ast = Marpa::R2::Internal::MetaAST->new($bnf); my $parse_result = $ast->ast_to_hash(); sub sort_bnf { my $cmp = $a->{lhs} cmp $b->{lhs}; return $cmp if $cmp; my $a_rhs_length = scalar @{ $a->{rhs} }; my $b_rhs_length = scalar @{ $b->{rhs} }; $cmp = $a_rhs_length <=> $b_rhs_length; return $cmp if $cmp; for my $ix ( 0 .. ( $a_rhs_length - 1 ) ) { $cmp = $a->{rhs}->[$ix] cmp $b->{rhs}->[$ix]; return $cmp if $cmp; } return 0; } ## end sub sort_bnf my %cooked_parse_result = ( character_classes => $parse_result->{character_classes}, symbols => $parse_result->{symbols}, lexeme_default_adverbs => $parse_result->{lexeme_default_adverbs}, first_lhs => $parse_result->{first_lhs}, start_lhs => $parse_result->{start_lhs}, ); my @rule_sets = keys %{ $parse_result->{rules} }; for my $rule_set (@rule_sets) { my $aoh = $parse_result->{rules}->{$rule_set}; my $sorted_aoh = [ sort sort_bnf @{$aoh} ]; $cooked_parse_result{rules}->{$rule_set} = $sorted_aoh; } say "## The code after this line was automatically generated by ", $PROGRAM_NAME; say "## Date: ", scalar localtime(); $Data::Dumper::Sortkeys = 1; print Data::Dumper->Dump( [ \%cooked_parse_result ], [qw(hashed_metag)] ); say "## The code before this line was automatically generated by ", $PROGRAM_NAME; Marpa-R2-2.086000~dfsg/lib/Marpa/R2/meta/metag.bnf0000444000000000000000000001772212342464707017655 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. :default ::= action => [start,length,values] bless => ::lhs lexeme default = action => [start,length,value] bless => ::name forgiving => 1 :start ::= statements statements ::= statement+ statement ::= | | | | | | | | | | | | | | ::= ';' ::= ('{') statements '}' ::= (':start' ) symbol ::= ('start' 'symbol' 'is') symbol ::= ':default' ::= ('lexeme' 'default' '=') ::= lhs priorities ::= lhs ::= lhs quantifier ::= (':discard' ) ::= (':lexeme' ) symbol ::= ('event') ('=' 'completed') ::= ('event') ('=' 'nulled') ::= ('event') ('=' 'predicted') ::= ('current' 'lexer' 'is') ::= ('inaccessible' 'is') ('by' 'default') ::= 'warn' | 'ok' | 'fatal' ::= | priorities ::= alternatives+ separator => proper => 1 alternatives ::= alternative+ separator => proper => 1 alternative ::= rhs ::= ::= * ::= action | | | | | | | | | | | | blessing | naming | ::= ',' action ::= ('action' '=>') ::= ('assoc' '=>' 'left') ::= ('assoc' '=>' 'right') ::= ('assoc' '=>' 'group') ::= ('separator' '=>') ::= ('proper' '=>') boolean ::= ('rank' '=>') ::= ('null-ranking' '=>') ::= ('null' 'rank' '=>') ::= 'low' | 'high' ::= ('priority' '=>') ::= ('pause' '=>') ::= ('event' '=>') ::= ('forgiving' '=>') boolean ::= ('latm' '=>') boolean ::= ('bless' '=>') ::= ('name' '=>') ::= | ::= | ::= | ::= ::= lhs ::= rhs ::= + ::= ::= ::= ::= ('(') (')') ::= + ::= symbol | symbol ::= ::= ::= ::= ::= ::= :discard ~ whitespace whitespace ~ [\s]+ # allow comments :discard ~ ~ | ~ '#' ~ '#' ~ * ~ [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] ~ [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] ~ '::=' ~ '~' ~ '||' ~ '|' quantifier ::= '*' | '+' ~ 'before' | 'after' ~ | ~ [+-] ~ [\d]+ boolean ~ [01] ~ '::' ~ '::' ~ [\w]+ ~ [\w]* # Perl identifiers allow an initial digit, which makes them slightly more liberal than Perl bare names # but equivalent to Perl names with sigils. ~ [\w]+ ~ '::' ~ + separator => proper => 1 ~ [\w]+ ~ [a-zA-Z] ~ '<' '>' ~ [\s\w]+ ~ ~ '[' ~ '[' whitespace ~ ']' ~ whitespace ']' ~ * separator => ~ [,] ~ [,] whitespace ~ 'start' | 'length' | 'name' | 'lhs' | 'symbol' | 'rule' | 'value' | 'values' # In single quotes strings and character classes # no escaping or internal newlines, and disallow empty string ~ ['] ['] ~ ['] ['] ~ [^'\x{0A}\x{0B}\x{0C}\x{0D}\x{0085}\x{2028}\x{2029}]+ ~ '[' ']' ~ + ~ # hex 5d is right square bracket ~ [^\x{5d}\x{0A}\x{0B}\x{0C}\x{0D}\x{0085}\x{2028}\x{2029}] ~ ~ '\' ~ ~ ~ * ~ ':ic' ~ ':i' # [=xyz=] and [.xyz.] are parsed by Perl, but then currently cause an exception. # Catching Perl exceptions is inconvenient for Marpa, # so we reject them syntactically instead. ~ '[:' ':]' ~ '[:^' ':]' ~ [[:alnum:]]+ # a horizontal character is any character that is not vertical space ~ [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] Marpa-R2-2.086000~dfsg/lib/Marpa/.gitignore0000444000000000000000000000004412342464707016635 0ustar rootrootR2.c R2.o R2.xs general_pattern.xsh Marpa-R2-2.086000~dfsg/.gitattributes0000444000000000000000000000003712342464707015734 0ustar rootroot*.pdf -crlf -text -diff -merge Marpa-R2-2.086000~dfsg/MANIFEST0000444000000000000000000002117012342464706014172 0ustar rootroot# Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # LC_ALL=C sort .gdbinit .gitattributes .gitignore Build.PL COPYING.LESSER Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml README author.t/.gitignore author.t/Makefile author.t/accept_tidy author.t/ampersand.t author.t/create_critic_list.pl author.t/critic.t author.t/critic1 author.t/display.t author.t/meta_yaml.t author.t/perlcriticrc author.t/perltidyrc author.t/pod.t author.t/spelling_exceptions.list author.t/tidy.t author.t/tidy1 etc/.gitignore etc/Makefile etc/check_license.pl etc/check_links.pl etc/compile_for_debug.sh etc/cp_libmarpa.sh etc/dovg.sh etc/my_suppressions etc/reserved_check.sh etc/work_to_dist.sh g/config/default.txt html/.gitignore html/lib/Marpa/R2/HTML.pm html/lib/Marpa/R2/HTML/.gitignore html/lib/Marpa/R2/HTML/Callback.pm html/lib/Marpa/R2/HTML/Config.pm html/lib/Marpa/R2/HTML/Config/Compile.pm html/lib/Marpa/R2/HTML/Config/Core.pm html/lib/Marpa/R2/HTML/Config/Default.pm html/lib/Marpa/R2/HTML/Internal.pm html/meta/Makefile html/meta/make_internal_pm.pl html/pod/HTML.pod html/pod/html_fmt.pod html/pod/html_score.pod html/script/marpa_r2_html_fmt html/script/marpa_r2_html_score html/t/00-load.t html/t/cfg_fmt.t html/t/config.t html/t/copy.t html/t/examples.t html/t/fmt.t html/t/fmt_t_data/expected1.html html/t/fmt_t_data/expected2.html html/t/fmt_t_data/input1.html html/t/fmt_t_data/input2.html html/t/fmt_t_data/score_expected1.html html/t/fmt_t_data/score_expected2.html html/t/missing.t html/t/no_tang.html html/t/parse.t html/t/score.t html/t/synopsis.t html/t/tang.t html/t/test.html html/tool/lib/Marpa/R2/HTML/Test/Util.pm inc/Marpa/R2/Build_Me.pm inc/Marpa/R2/Config.pm inc/Marpa/R2/Display.pm inc/Marpa/R2/License.pm inc/Marpa/R2/Test.pm inc/Marpa/R2/legal.pl inc/drafts/undocumented.list lib/Marpa/.gitignore lib/Marpa/R2.pm lib/Marpa/R2/.gitignore lib/Marpa/R2/ASF.pm lib/Marpa/R2/Grammar.pm lib/Marpa/R2/Internal.pm lib/Marpa/R2/MetaAST.pm lib/Marpa/R2/MetaG.pm lib/Marpa/R2/Recognizer.pm lib/Marpa/R2/SLG.pm lib/Marpa/R2/SLR.pm lib/Marpa/R2/Stuifzand.pm lib/Marpa/R2/Thin/Trace.pm lib/Marpa/R2/Value.pm lib/Marpa/R2/meta/Makefile lib/Marpa/R2/meta/metag.bnf lib/Marpa/R2/meta/sl_to_hash.pl libmarpa/.gitignore libmarpa/Makefile libmarpa/ac/AUTHORS libmarpa/ac/COPYING.LESSER libmarpa/ac/ChangeLog libmarpa/ac/Makefile.am libmarpa/ac/NEWS libmarpa/ac/README libmarpa/ac/configure.ac libmarpa/ac_doc/AUTHORS libmarpa/ac_doc/COPYING.LESSER libmarpa/ac_doc/ChangeLog libmarpa/ac_doc/Makefile.am libmarpa/ac_doc/NEWS libmarpa/ac_doc/README libmarpa/ac_doc/configure.ac libmarpa/ac_doc/fdl-1.3.texi libmarpa/ac_doc/lgpl-3.0.texi libmarpa/ami/.gitignore libmarpa/ami/Makefile libmarpa/ami/api.texi libmarpa/ami/internal.texi libmarpa/ami/marpa_ami.w libmarpa/ami/w2private_h.pl libmarpa/avl/marpa_avl.c libmarpa/avl/marpa_avl.h libmarpa/bin/cppwrap.pl libmarpa/bin/texi2proto.pl libmarpa/bin/to_stage.pl libmarpa/bin/too_long.pl libmarpa/dev/.gitignore libmarpa/dev/Makefile libmarpa/dev/README libmarpa/dev/api.texi libmarpa/dev/internal.texi libmarpa/dev/legacy.w libmarpa/dev/marpa.w libmarpa/dev/w2private_h.pl libmarpa/notes/shared_test.txt libmarpa/obs/marpa_obs.c libmarpa/obs/marpa_obs.h libmarpa/public/.gitignore libmarpa/public/LIB_VERSION.in libmarpa/public/Makefile libmarpa/public/marpa.h-version libmarpa/public/marpa.h.p10 libmarpa/public/marpa.h.p90 libmarpa/public/marpa_codes.c.p10 libmarpa/public/marpa_slif.h.p20 libmarpa/public/texi2err.pl libmarpa/public/texi2event.pl libmarpa/public/texi2step.pl libmarpa/shared/copyright_page_license.w libmarpa/shared/cwebmac.tex libmarpa/shared/do_not_edit.c libmarpa/shared/license.c libmarpa/slif/.gitignore libmarpa/slif/Makefile libmarpa/slif/api.texi libmarpa/slif/create_ops.pl libmarpa/slif/internal.texi libmarpa/slif/marpa_slif.w libmarpa/slif/w2private_h.pl libmarpa/tavl/.gitignore libmarpa/tavl/Makefile libmarpa/tavl/README libmarpa/tavl/README.Pfaff libmarpa/tavl/marpa_tavl.c libmarpa/tavl/marpa_tavl.h libmarpa/tavl/tavl-test.c libmarpa/tavl/test.c libmarpa/tavl/test.h libmarpa/win32/Makefile.win32 libmarpa/win32/do_config_h.pl libmarpa/win32/make.bat libmarpa_dist/AUTHORS libmarpa_dist/COPYING.LESSER libmarpa_dist/ChangeLog libmarpa_dist/INSTALL libmarpa_dist/LIB_VERSION libmarpa_dist/LIB_VERSION.in libmarpa_dist/Makefile.am libmarpa_dist/Makefile.in libmarpa_dist/Makefile.win32 libmarpa_dist/NEWS libmarpa_dist/README libmarpa_dist/aclocal.m4 libmarpa_dist/config.guess libmarpa_dist/config.h.in libmarpa_dist/config.sub libmarpa_dist/configure libmarpa_dist/configure.ac libmarpa_dist/depcomp libmarpa_dist/install-sh libmarpa_dist/ltmain.sh libmarpa_dist/m4/libtool.m4 libmarpa_dist/m4/ltoptions.m4 libmarpa_dist/m4/ltsugar.m4 libmarpa_dist/m4/ltversion.m4 libmarpa_dist/m4/lt~obsolete.m4 libmarpa_dist/marpa.c libmarpa_dist/marpa.h libmarpa_dist/marpa_ami.c libmarpa_dist/marpa_ami.h libmarpa_dist/marpa_avl.c libmarpa_dist/marpa_avl.h libmarpa_dist/marpa_codes.c libmarpa_dist/marpa_obs.c libmarpa_dist/marpa_obs.h libmarpa_dist/marpa_slif.c libmarpa_dist/marpa_slif.h libmarpa_dist/marpa_tavl.c libmarpa_dist/marpa_tavl.h libmarpa_dist/missing libmarpa_dist/notes/shared_test.txt libmarpa_dist/stamp-h1 libmarpa_dist/win32/do_config_h.pl libmarpa_dist/win32/marpa.def libmarpa_doc_dist/AUTHORS libmarpa_doc_dist/COPYING.LESSER libmarpa_doc_dist/ChangeLog libmarpa_doc_dist/INSTALL libmarpa_doc_dist/Makefile.am libmarpa_doc_dist/Makefile.in libmarpa_doc_dist/NEWS libmarpa_doc_dist/README libmarpa_doc_dist/aclocal.m4 libmarpa_doc_dist/api.info libmarpa_doc_dist/api.texi libmarpa_doc_dist/configure libmarpa_doc_dist/configure.ac libmarpa_doc_dist/fdl-1.3.texi libmarpa_doc_dist/install-sh libmarpa_doc_dist/internal.info libmarpa_doc_dist/internal.texi libmarpa_doc_dist/lgpl-3.0.texi libmarpa_doc_dist/mdate-sh libmarpa_doc_dist/missing libmarpa_doc_dist/stamp-1 libmarpa_doc_dist/stamp-h1 libmarpa_doc_dist/stamp-vti libmarpa_doc_dist/texinfo.tex libmarpa_doc_dist/version.texi libmarpa_doc_dist/version_i.texi meta/Makefile meta/make_internal_pm.pl pod/ASF.pod pod/Acknowledgements.pod pod/Advanced/Bibliography.pod pod/Advanced/Models.pod pod/Advanced/Thin.pod pod/BNF.pod pod/Changes.pod pod/Glade.pod pod/Marpa_R2.pod pod/NAIF.pod pod/NAIF/Grammar.pod pod/NAIF/Progress.pod pod/NAIF/Recognizer.pod pod/NAIF/Semantics.pod pod/NAIF/Semantics/Infinite.pod pod/NAIF/Semantics/Null.pod pod/NAIF/Semantics/Order.pod pod/NAIF/Semantics/Phases.pod pod/NAIF/Tracing.pod pod/Progress.pod pod/Scanless.pod pod/Scanless/DSL.pod pod/Scanless/G.pod pod/Scanless/R.pod pod/Semantics.pod pod/Semantics/Null.pod pod/Semantics/Order.pod pod/Semantics/Phases.pod pod/Support.pod pod/Tracing.pod pod/Vocabulary.pod pperl/Marpa/R2/Perl.pm pperl/Marpa/R2/Perl/.gitignore t/.gitignore t/00-load.t t/ah2.t t/ah_numeric.t t/asf_syn.t t/balanced.t t/bocage.t t/catalan.t t/chaf.t t/code_diag.t t/context.t t/counter.t t/curly.t t/curly2.t t/debug.t t/debug_leo.t t/debug_seq.t t/deprecated1.t t/dsl.t t/duplicate_parse.t t/equation.t t/etc/wall_proof.txt t/final_nonnullable.t t/gabend.t t/implementation.t t/infinite.t t/infinite2.t t/infinite_plex.t t/initial_nulls.t t/jirotka.t t/leo.t t/leo2.t t/leo3.t t/leo_cycle.t t/leo_example.t t/leo_unit.t t/limits.t t/minus.t t/naif.t t/null_example.t t/null_infinite1.t t/null_infinite4.t t/null_value.t t/pascal.t t/perl.t t/rabend.t t/randal.t t/rewrite.t t/sequence.t t/sequence2.t t/sl_action.t t/sl_action2.t t/sl_advent.t t/sl_ah2.t t/sl_ambig.t t/sl_ast.t t/sl_astsyn.t t/sl_calc.t t/sl_completed.t t/sl_debug.t t/sl_diag.t t/sl_dsl.t t/sl_durand.t t/sl_dyck.t t/sl_event.t t/sl_exhaust.t t/sl_external1.t t/sl_fullsyn.t t/sl_gia.t t/sl_gia_err.t t/sl_gie.t t/sl_gif1.t t/sl_gires.t t/sl_gsyn.t t/sl_json.t t/sl_json_ast.t t/sl_leo.t t/sl_leo2.t t/sl_lexevent.t t/sl_null_example.t t/sl_numeric.t t/sl_panda.t t/sl_panda1.t t/sl_pascal.t t/sl_prefix.t t/sl_rank.t t/sl_syn.t t/sl_taint.t t/sl_timeflies.t t/sl_topsyn.t t/sl_wall.t t/stuifzand.t t/syn_engine.t t/syn_stuifzand.t t/thin_deprec.t t/thin_eq.t t/timeflies.t t/use.t typemap xs/.gitignore xs/Makefile xs/R2.xs xs/general_pattern.xsh xs/gp_generate.pl xs/ppport.h Marpa-R2-2.086000~dfsg/LICENSE0000444000000000000000000000145112342464706014046 0ustar rootrootCopyright 2014 Jeffrey Kegler This file is part of Marpa::R2. Marpa::R2 is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. Marpa::R2 is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with Marpa::R2. If not, see http://www.gnu.org/licenses/. In the Marpa::R2 distribution, the GNU Lesser General Public License version 3 should be in a file named "COPYING.LESSER". Marpa-R2-2.086000~dfsg/t/0000755000000000000000000000000012342464707013306 5ustar rootrootMarpa-R2-2.086000~dfsg/t/sequence2.t0000444000000000000000000000664712342464706015377 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Tests of the sequence in the Marpa::R2::Grammar doc use 5.010; use strict; use warnings; use Fatal qw(open close); use Test::More tests => 3; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; sub do_sequence { shift; return 'seq(' . ( join q{;}, @_ ) . ')' } sub do_item { shift; return 'item(' . ( join q{;}, @_ ) . ')' } my $grammar; my $recce; my $value_ref; my $value; my $min0 = #<<< no perltidy # Marpa::R2::Display # name: Marpa::R2::Grammar min 0 sequence example { lhs => 'sequence', rhs => ['item'], min => 0, action => 'do_sequence' } # Marpa::R2::Display::End ; # semicolon to terminate rule $grammar = Marpa::R2::Grammar->new( { start => 'sequence', terminals => [qw(item)], rules => [$min0], actions => 'main' } ); $grammar->precompute(); $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); $recce->read( 'item', '0'); $recce->read( 'item', '1'); $value_ref = $recce->value(); $value = $value_ref ? ${$value_ref} : 'No Parse'; $value //= 'undef returned'; Marpa::R2::Test::is( $value, 'seq(0;1)', 'min 0 value' ); my $min1 = #<<< no perltidy # Marpa::R2::Display # name: Marpa::R2::Grammar min 1 sequence example { lhs => 'sequence', rhs => ['item'], min => 1, action => 'do_sequence' } # Marpa::R2::Display::End ; # semicolon to terminate rule $grammar = Marpa::R2::Grammar->new({ start => 'sequence', rules => [ $min1 ], actions => 'main' }); $grammar->precompute(); $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); $recce->read( 'item', '0'); $recce->read( 'item', '1'); $value_ref = $recce->value(); $value = $value_ref ? ${$value_ref} : 'No Parse'; $value //= 'undef returned'; Marpa::R2::Test::is( $value, 'seq(0;1)', 'min 1 value' ); my $multipart = [ #<<< no perltidy # Marpa::R2::Display # name: Marpa::R2::Grammar multipart rhs sequence example { lhs => 'sequence', rhs => [qw(item)], min => 0, action => 'do_sequence' }, { lhs => 'item', rhs => [qw(part1 part2)], action => 'do_item' }, # Marpa::R2::Display::End ]; # semicolon to terminate rule $grammar = Marpa::R2::Grammar->new( { start => 'sequence', terminals => [qw(part1 part2)], rules => $multipart, actions => 'main' } ); $grammar->precompute(); $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); $recce->read( 'part1', '0' ); $recce->read( 'part2', '1' ); $value_ref = $recce->value(); $value = $value_ref ? ${$value_ref} : 'No Parse'; $value //= 'undef returned'; Marpa::R2::Test::is( $value, 'seq(item(0;1))', 'multipart rhs value' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/curly2.t0000444000000000000000000001656612342464707014727 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use warnings; use strict; use English qw( -no_match_vars ); use Test::More ( import => [] ); use lib 'pperl'; BEGIN { my $PPI_problem; CHECK_PPI: { if ( not eval { require PPI } ) { $PPI_problem = "PPI not installed: $EVAL_ERROR"; last CHECK_PPI; } if ( not PPI->VERSION(1.206) ) { $PPI_problem = 'PPI 1.206 not installed'; } } ## end CHECK_PPI: if ($PPI_problem) { Test::More::plan skip_all => $PPI_problem; } else { Test::More::plan tests => 1; } } ## end BEGIN use Marpa::R2; use Marpa::R2::Perl; use lib 'inc'; use Marpa::R2::Test; my $input_string = <<'END_OF_INPUT'; Note: line:column figures include preceding whitepace The next line is a perl fragment {42;{1,2,3;4}} Code block from 3:5 to 3:13 Code block from 2:33 to 3:14 The next line is a perl fragment {42;{1,2,3,4}} Hash from 7:5 to 7:13 Code block from 7:5 to 7:13 Code block from 6:33 to 7:14 The next line is a perl fragment {42;{;1,2,3;4}} Code block from 12:5 to 12:14 Code block from 11:33 to 12:15 The next line is a perl fragment {42;+{1,2,3,4}} Hash from 16:6 to 16:14 Code block from 15:33 to 16:15 END_OF_INPUT my $finder = Marpa::R2::Perl->new( { embedded => 1, closures => {} } ); my $main_parser = Marpa::R2::Perl->new( { closures => {} } ); sub linecol { my ($token) = @_; return q{?} if not defined $token; return $token->logical_line_number() . q{:} . $token->column_number; } my $tokens = $finder->tokens( \$input_string ); $main_parser->clone_tokens($finder); my $count_of_tokens = scalar @{$tokens}; my $perl_found = 0; my $next_start = 0; my $main_result = q{}; PERL_CODE: while (1) { last PERL_CODE if $next_start >= $count_of_tokens; my ( $start, $end ) = $finder->find_perl($next_start); if ( not defined $start ) { $next_start = $end + 1; next PERL_CODE; } $perl_found += ( $end - $start ) + 1; my $perl_code = join q{}, map { $_->content() } @{$tokens}[ $start .. $end ]; $perl_code =~ s/\A \s*//xms; $perl_code =~ s/\s* \z//xms; $main_result .= "Perl fragment: $perl_code\n"; $main_result .= find_curly( $main_parser, $start, $end ); $next_start = $end + 1; } ## end PERL_CODE: while (1) $main_result .= sprintf "perl tokens = %d; all tokens=%d; %.2f%%\n", $perl_found, $count_of_tokens, ( $perl_found / $count_of_tokens ) * 100; Marpa::R2::Test::is( $main_result, <<'END_OF_OUTPUT', 'Output' ); Perl fragment: {42;{1,2,3;4}} Code block at 3:5 3:13 {1,2,3;4} Code block at 2:33 3:14 {42;{1,2,3;4}} Perl fragment: {42;{1,2,3,4}} Ambiguous Hash at 7:5 7:13 {1,2,3,4} Ambiguous Code block at 7:5 7:13 {1,2,3,4} Code block at 6:33 7:14 {42;{1,2,3,4}} Perl fragment: {42;{;1,2,3;4}} Code block at 12:5 12:14 {;1,2,3;4} Code block at 11:33 12:15 {42;{;1,2,3;4}} Perl fragment: {42;+{1,2,3,4}} Hash at 16:6 16:14 {1,2,3,4} Code block at 15:33 16:15 {42;+{1,2,3,4}} perl tokens = 62; all tokens=267; 23.22% END_OF_OUTPUT sub find_curly { my ( $parser, $token_start_ix, $token_end_ix ) = @_; my $result = q{}; $parser->read_tokens( $token_start_ix, $token_end_ix ); my $recce = $parser->{recce}; my $earleme_to_token = $parser->{earleme_to_PPI_token}; my $PPI_tokens = $parser->{PPI_tokens}; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; for my $earley_set_id ( 0 .. $recce->latest_earley_set() ) { my @hash_locations = (); my @code_locations = (); my $progress_report = $recce->progress($earley_set_id); ITEM: for my $progress_item ( @{$progress_report} ) { my ( $rule_id, $position, $origin_earley_set_id ) = @{$progress_item}; last ITEM if not defined $rule_id; next ITEM if $position >= 0; $position = $grammar_c->rule_length($rule_id); my $origin_earleme = $recce->earleme($origin_earley_set_id); my $rule = $rules->[$rule_id]; my $rule_name = $rule->[Marpa::R2::Internal::Rule::NAME]; next ITEM if not defined $rule_name; my $blocktype = $rule_name eq 'anon_hash' ? 'hash' : $rule_name eq 'block' ? 'code' : $rule_name eq 'mblock' ? 'code' : undef; next ITEM if not defined $blocktype; my $token = $PPI_tokens->[ $earleme_to_token->[$origin_earleme] ]; push @hash_locations, [ $origin_earleme, $earley_set_id - 1 ] if $blocktype eq 'hash'; push @code_locations, [ $origin_earleme, $earley_set_id - 1 ] if $blocktype eq 'code'; } ## end ITEM: for my $progress_item ( @{$progress_report} ) my @ambiguous = (); push @ambiguous, 'Ambiguous' if scalar @hash_locations and scalar @code_locations; for my $hash_location (@hash_locations) { my ( $start, $end ) = @{$hash_location}; my $start_ix = $earleme_to_token->[$start]; my $end_ix = $earleme_to_token->[$end]; while ( not defined $end_ix ) { $end_ix = $earleme_to_token->[ --$end ]; } my $string = join q{}, map { $_->content() } @{$tokens}[ $start_ix .. $end_ix ]; $string =~ s/\A \s* //xms; $string =~ s/\s* \z//xms; $result .= join q{ }, @ambiguous, 'Hash at', linecol( $PPI_tokens->[$start_ix] ), linecol( $PPI_tokens->[$end_ix] ), $string; $result .= "\n"; } ## end for my $hash_location (@hash_locations) for my $code_location (@code_locations) { my ( $start, $end ) = @{$code_location}; my $start_ix = $earleme_to_token->[$start]; my $end_ix = $earleme_to_token->[$end]; while ( not defined $end_ix ) { $end_ix = $earleme_to_token->[ --$end ]; } my $string = join q{}, map { $_->content() } @{$tokens}[ $start_ix .. $end_ix ]; $string =~ s/\A \s*//xms; $string =~ s/\s* \z//xms; $result .= join q{ }, @ambiguous, 'Code block at', linecol( $PPI_tokens->[$start_ix] ), linecol( $PPI_tokens->[$end_ix] ), $string; $result .= "\n"; } ## end for my $code_location (@code_locations) } ## end for my $earley_set_id ( 0 .. $recce->latest_earley_set...) return $result; } ## end sub find_curly # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/debug.t0000444000000000000000000001632312342464707014564 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use Test::More tests => 12; use English qw( -no_match_vars ); use Fatal qw( open close ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; use Data::Dumper; my $progress_report = q{}; # Marpa::R2::Display # name: Debug Example Part 1 my $grammar = Marpa::R2::Grammar->new( { start => 'Expression', actions => 'My_Actions', default_action => 'first_arg', rules => [ ## This is a deliberate error in the grammar ## The next line should be: ## { lhs => 'Expression', rhs => [qw/Term/] }, ## I have changed the Term to 'Factor' which ## will cause problems. { lhs => 'Expression', rhs => [qw/Factor/] }, { lhs => 'Term', rhs => [qw/Factor/] }, { lhs => 'Factor', rhs => [qw/Number/] }, { lhs => 'Term', rhs => [qw/Term Add Term/], action => 'do_add' }, { lhs => 'Factor', rhs => [qw/Factor Multiply Factor/], action => 'do_multiply' }, ], } ); # Marpa::R2::Display::End ## no critic (InputOutput::RequireBriefOpen) open my $trace_fh, q{>}, \( my $trace_output = q{} ); ## use critic # Marpa::R2::Display # name: Grammar set Synopsis $grammar->set( { trace_file_handle => $trace_fh } ); # Marpa::R2::Display::End # Marpa::R2::Display # name: Debug Example Part 2 $grammar->precompute(); my @tokens = ( [ 'Number', 42 ], [ 'Multiply', q{*} ], [ 'Number', 1 ], [ 'Add', q{+} ], [ 'Number', 7 ], ); sub My_Actions::do_add { my ( undef, $t1, undef, $t2 ) = @_; return $t1 + $t2; } sub My_Actions::do_multiply { my ( undef, $t1, undef, $t2 ) = @_; return $t1 * $t2; } sub My_Actions::first_arg { shift; return shift; } my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, trace_terminals => 2 } ); my $token_ix = 0; TOKEN: for my $token_and_value (@tokens) { last TOKEN if not defined $recce->read( @{$token_and_value} ); } $progress_report = $recce->show_progress( 0, -1 ); # Marpa::R2::Display::End my $value_ref = $recce->value; my $value = $value_ref ? ${$value_ref} : 'No Parse'; Test::More::is( $value, 42, 'value' ); # Marpa::R2::Display # name: Debug Example Progress Report # start-after-line: END_PROGRESS_REPORT # end-before-line: '^END_PROGRESS_REPORT$' Marpa::R2::Test::is( $progress_report, <<'END_PROGRESS_REPORT', 'progress report' ); P0 @0-0 Expression -> . Factor P2 @0-0 Factor -> . Number P4 @0-0 Factor -> . Factor Multiply Factor F0 @0-1 Expression -> Factor . F2 @0-1 Factor -> Number . R4:1 @0-1 Factor -> Factor . Multiply Factor P2 @2-2 Factor -> . Number P4 @2-2 Factor -> . Factor Multiply Factor R4:2 @0-2 Factor -> Factor Multiply . Factor F0 @0-3 Expression -> Factor . F2 @2-3 Factor -> Number . R4:1 x2 @0,2-3 Factor -> Factor . Multiply Factor F4 @0-3 Factor -> Factor Multiply Factor . END_PROGRESS_REPORT # Marpa::R2::Display::End $Data::Dumper::Indent = 0; $Data::Dumper::Terse = 1; # Marpa::R2::Display # name: progress(0) example my $report0 = $recce->progress(0); # Marpa::R2::Display::End # Marpa::R2::Display # name: progress() output at location 0 # start-after-line: END_PROGRESS_REPORT # end-before-line: '^END_PROGRESS_REPORT$' chomp( my $expected_report0 = <<'END_PROGRESS_REPORT'); [[0,0,0],[2,0,0],[4,0,0]] END_PROGRESS_REPORT Marpa::R2::Test::is( Data::Dumper::Dumper($report0), $expected_report0, 'progress report at location 0' ); # Marpa::R2::Display::End # Try again with negative index $report0 = $recce->progress(-4); Marpa::R2::Test::is( Data::Dumper::Dumper($report0), $expected_report0, 'progress report at location -4' ); my $report1 = $recce->progress(1); # Marpa::R2::Display # name: progress() output at location 1 # start-after-line: END_PROGRESS_REPORT # end-before-line: '^END_PROGRESS_REPORT$' chomp( my $expected_report1 = <<'END_PROGRESS_REPORT'); [[0,-1,0],[2,-1,0],[4,1,0]] END_PROGRESS_REPORT Marpa::R2::Test::is( Data::Dumper::Dumper($report1), $expected_report1, 'progress report at location 1' ); # Marpa::R2::Display::End # Try again with negative index $report1 = $recce->progress(-3); Marpa::R2::Test::is( Data::Dumper::Dumper($report1), $expected_report1, 'progress report at location -3' ); my $report2 = $recce->progress(2); # Marpa::R2::Display # name: progress() output at location 2 # start-after-line: END_PROGRESS_REPORT # end-before-line: '^END_PROGRESS_REPORT$' chomp( my $expected_report2 = <<'END_PROGRESS_REPORT'); [[2,0,2],[4,0,2],[4,2,0]] END_PROGRESS_REPORT Marpa::R2::Test::is( Data::Dumper::Dumper($report2), $expected_report2, 'progress report at location 2' ); # Marpa::R2::Display::End # Try again with negative index $report2 = $recce->progress(-2); Marpa::R2::Test::is( Data::Dumper::Dumper($report2), $expected_report2, 'progress report at location -2' ); # Marpa::R2::Display # name: progress() example my $latest_report = $recce->progress(); # Marpa::R2::Display::End # Marpa::R2::Display # name: progress() output at location 3 # start-after-line: END_PROGRESS_REPORT # end-before-line: '^END_PROGRESS_REPORT$' chomp( my $expected_report3 = <<'END_PROGRESS_REPORT'); [[0,-1,0],[2,-1,2],[4,-1,0],[4,1,0],[4,1,2]] END_PROGRESS_REPORT Marpa::R2::Test::is( Data::Dumper::Dumper($latest_report), $expected_report3, 'progress report at location 3' ); # Marpa::R2::Display::End # Try latest report again with explicit index my $report3 = $recce->progress(3); Marpa::R2::Test::is( Data::Dumper::Dumper($report3), $expected_report3, 'progress report at location 3' ); # Try latest report again with negative index $latest_report = $recce->progress(-1); Marpa::R2::Test::is( Data::Dumper::Dumper($latest_report), $expected_report3, 'progress report at location -1' ); # Marpa::R2::Display # name: Debug Example Trace Output # start-after-line: END_TRACE_OUTPUT # end-before-line: '^END_TRACE_OUTPUT$' Marpa::R2::Test::is( $trace_output, <<'END_TRACE_OUTPUT', 'trace output' ); Inaccessible symbol: Add Inaccessible symbol: Term Setting trace_terminals option Expecting "Number" at earleme 0 Accepted "Number" at 0-1 Expecting "Multiply" at 1 Accepted "Multiply" at 1-2 Expecting "Number" at 2 Accepted "Number" at 2-3 Expecting "Multiply" at 3 Rejected "Add" at 3-4 END_TRACE_OUTPUT # Marpa::R2::Display::End 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_ah2.t0000444000000000000000000001103612342464707014642 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # the example grammar in Aycock/Horspool "Practical Earley Parsing", # _The Computer Journal_, Vol. 45, No. 6, pp. 620-630, # in its "NNF" form use 5.010; use strict; use warnings; use Test::More tests => 26; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . ( join q{;}, @_ ) . ')'; } ## end sub default_action ## use critic my $dsl = <<'END_OF_DSL'; :default ::= action => main::default_action :start ::= S S ::= A A A A A ::= A ::= 'a' END_OF_DSL my $slg = Marpa::R2::Scanless::G->new( { source => \$dsl }); my $slr = Marpa::R2::Scanless::R->new( { grammar => $slg }); my $input_length = 4; my $input = ('a' x $input_length); $slr->read( \$input ); my @expected = map { +{ map { ( $_ => 1 ) } @{$_} } } [q{}], [qw( (a;;;) (;a;;) (;;a;) (;;;a) )], [qw( (a;a;;) (a;;a;) (a;;;a) (;a;a;) (;a;;a) (;;a;a) )], [qw( (a;a;a;) (a;a;;a) (a;;a;a) (;a;a;a) )], ['(a;a;a;a)']; $slr->set( { max_parses => 20 } ); my @ambiguity_expected; $ambiguity_expected[0] = 'No ambiguity'; $ambiguity_expected[1] = <<'END_OF_AMBIGUITY_DESC'; Length of symbol "A" at line 1, column 1 is ambiguous Choice 1, length=1, ends at line 1, column 1 Choice 1: a Choice 2 is zero length END_OF_AMBIGUITY_DESC $ambiguity_expected[2] = <<'END_OF_AMBIGUITY_DESC'; Length of symbol "A" at line 1, column 1 is ambiguous Choice 1 is zero length Choice 2, length=1, ends at line 1, column 1 Choice 2: a END_OF_AMBIGUITY_DESC $ambiguity_expected[3] = <<'END_OF_AMBIGUITY_DESC'; Length of symbol "A" at line 1, column 1 is ambiguous Choice 1 is zero length Choice 2, length=1, ends at line 1, column 1 Choice 2: a Length of symbol "A" at line 1, column 2 is ambiguous Choice 1, length=1, ends at line 1, column 2 Choice 1: a Choice 2 is zero length END_OF_AMBIGUITY_DESC $ambiguity_expected[4] = 'No ambiguity'; for my $i ( 0 .. $input_length ) { $slr->series_restart( { end => $i } ); my $expected = $expected[$i]; # Marpa::R2::Display # name: Scanless ambiguity_metric() synopsis my $ambiguity_metric = $slr->ambiguity_metric(); # Marpa::R2::Display::End $ambiguity_metric = 2 if $ambiguity_metric > 2; # cap at 2 -- higher numbers not defined my $expected_metric = (scalar keys %{$expected} > 1 ? 2 : 1); Test::More::is($ambiguity_metric, $expected_metric, "Ambiguity check for length $i"); while ( my $value_ref = $slr->value() ) { my $value = $value_ref ? ${$value_ref} : 'No parse'; if ( defined $expected->{$value} ) { delete $expected->{$value}; Test::More::pass(qq{Expected result for length=$i, "$value"}); } else { Test::More::fail(qq{Unexpected result for length=$i, "$value"}); } } ## end while ( my $value_ref = $slr->value() ) for my $value ( keys %{$expected} ) { Test::More::fail(qq{Missing result for length=$i, "$value"}); } my $ambiguity_desc = 'No ambiguity'; if ($ambiguity_metric > 1) { $slr->series_restart( { end => $i } ); my $asf = Marpa::R2::ASF->new( { slr => $slr } ); die 'No ASF' if not defined $asf; my $ambiguities = Marpa::R2::Internal::ASF::ambiguities($asf); # Only report the first two my @ambiguities = grep {defined} @{$ambiguities}[ 0 .. 1 ]; $ambiguity_desc = Marpa::R2::Internal::ASF::ambiguities_show( $asf, \@ambiguities ); } Marpa::R2::Test::is($ambiguity_desc, $ambiguity_expected[$i], "Ambiguity description for length $i"); } ## end for my $i ( 0 .. $input_length ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_pascal.t0000444000000000000000000000616012342464706015434 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; # A variation on # the example grammar in Aycock/Horspool "Practical Earley Parsing", # _The Computer Journal_, Vol. 45, No. 6, pp. 620-630, # Its order of ambiguity generates Pascal's triangle. use strict; use warnings; use Test::More tests => 6; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $base_dsl = <<'END_OF_BASE_DSL'; :start ::= S A ::= 'a' | E E ::= # empty END_OF_BASE_DSL sub ah_extended { my $n = shift; my $full_dsl = $base_dsl . join q{ }, 'S', '::=', ( ('A') x $n ); my $slg = Marpa::R2::Scanless::G->new( { source => \$full_dsl, } ); my $input = 'a' x $n; my $slr = Marpa::R2::Scanless::R->new( { grammar => $slg } ); $slr->read( \$input ); my @parse_counts = (1); for my $loc ( 1 .. $n ) { my $parse_number = 0; $slr->series_restart( { end => $loc } ); my $asf = Marpa::R2::ASF->new( { slr => $slr , factoring_max => 1000} ); $parse_counts[$loc] = $asf->traverse( {}, sub { my ($glade) = @_; my $glade_count = 0; do { my $rule_count = 1; if ( defined $glade->rule_id() ) { $rule_count *= $glade->rh_value($_) for 0 .. $glade->rh_length() - 1; } $glade_count += $rule_count; $glade->literal(); } while defined $glade->next(); return $glade_count; } ); } ## end for my $loc ( 0 .. $n ) return join q{ }, @parse_counts; } ## end sub ah_extended # In the NAIF, the zero case was one of my more important tests, # but allowing a SLIF whose lexers are never used seems pointless. my @answers = ( undef, '1 1', '1 2 1', '1 3 3 1', '1 4 6 4 1', '1 5 10 10 5 1', '1 6 15 20 15 6 1', '1 7 21 35 35 21 7 1', '1 8 28 56 70 56 28 8 1', '1 9 36 84 126 126 84 36 9 1', '1 10 45 120 210 252 210 120 45 10 1', ); ## no critic (ValuesAndExpressions::ProhibitMagicNumbers) for my $a ( ( 1 .. 5 ), 10 ) { ## use critic Marpa::R2::Test::is( ah_extended($a), $answers[$a], "Row $a of Pascal's triangle matches parse counts" ); } ## end for my $a ( ( 0 .. 5 ), 10 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: set expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sequence.t0000444000000000000000000001015512342464707015303 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Basic tests of sequences. # The matrix is separation (none/perl5/proper); # and minimium count (0, 1, 3); # keep vs. no-keep. use 5.010; use strict; use warnings; use Test::More tests => 70; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . join( q{;}, @_ ) . ')'; } ## end sub default_action ## use critic sub run_sequence_test { my ( $minimum, $separation, $keep ) = @_; my @terminals = ('A'); my @separation_args = (); if ( $separation ne 'none' ) { push @separation_args, separator => 'sep'; push @terminals, 'sep'; } if ( $separation eq 'proper' ) { push @separation_args, proper => 1; } my $grammar = Marpa::R2::Grammar->new( { start => 'TOP', rules => [ { lhs => 'TOP', rhs => [qw/A/], min => $minimum, keep => $keep, @separation_args }, ], default_action => 'main::default_action', } ); $grammar->set( { terminals => \@terminals } ); $grammar->precompute(); # Number of symbols to test at the higher numbers is # more or less arbitrary. You really need to test 0 .. 3. # And you ought to test a couple of higher values, # say 5 and 10. SYMBOL_COUNT: for my $symbol_count ( 0, 1, 2, 3, 5, 10 ) { next SYMBOL_COUNT if $symbol_count < $minimum; my $test_name = "min=$minimum;" . ( $keep ? 'keep;' : q{} ) . ( $separation ne 'none' ? "$separation;" : q{} ) . ";count=$symbol_count"; my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); my @expected = (); my $last_symbol_ix = $symbol_count - 1; SYMBOL_IX: for my $symbol_ix ( 0 .. $last_symbol_ix ) { push @expected, 'a'; $recce->read( 'A', 'a' ) and $recce->exhausted() and die 'Parsing exhausted'; next SYMBOL_IX if $separation eq 'none'; next SYMBOL_IX if $symbol_ix >= $last_symbol_ix and $separation ne 'perl5'; if ($keep) { push @expected, q{!}; } $recce->read( 'sep', q{!} ) and $recce->exhausted() and die 'Parsing exhausted'; } ## end for my $symbol_ix ( 0 .. $last_symbol_ix ) $recce->end_input(); my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; my $expected = join q{;}, @expected; if ( @expected > 1 ) { $expected = "($expected)"; } Test::More::is( $value, $expected, $test_name ); } ## end for my $symbol_count ( 0, 1, 2, 3, 5, 10 ) return; } ## end sub run_sequence_test for my $minimum ( 0, 1, 3 ) { run_sequence_test( $minimum, 'none', 0 ); for my $separation (qw(proper perl5)) { for my $keep ( 0, 1 ) { run_sequence_test( $minimum, $separation, $keep ); } } } ## end for my $minimum ( 0, 1, 3 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_action.t0000444000000000000000000001013612342464707015445 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # SLIF semantics examples use 5.010; use strict; use warnings; use Test::More tests => 6; use English qw( -no_match_vars ); use Fatal qw( open close ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $trace_rules = q{}; # Marpa::R2::Display # name: SLIF action context synopsis sub do_S { my ($action_object) = @_; my $rule_id = $Marpa::R2::Context::rule; my $slg = $Marpa::R2::Context::slg; my ( $lhs, @rhs ) = map { $slg->symbol_display_form($_) } $slg->rule_expand($rule_id); $action_object->{text} = "rule $rule_id: $lhs ::= " . ( join q{ }, @rhs ) . "\n" . "locations: " . ( join q{-}, Marpa::R2::Context::location() ) . "\n"; return $action_object; } ## end sub do_S # Marpa::R2::Display::End # Marpa::R2::Display # name: SLIF bail synopsis my $bail_message = "This is a bail out message!"; sub do_bail_with_message_if_A { my ($action_object, $terminal) = @_; Marpa::R2::Context::bail($bail_message) if $terminal eq 'A'; } sub do_bail_with_object_if_A { my ($action_object, $terminal) = @_; Marpa::R2::Context::bail([$bail_message]) if $terminal eq 'A'; } # Marpa::R2::Display::End my @terminals = qw/A B C D/; my $grammar = Marpa::R2::Scanless::G->new( { source => \<<'END_OF_SOURCE', :start ::= S S ::= A B C D action => main::do_S A ~ 'A' B ~ 'B' C ~ 'C' D ~ 'D' END_OF_SOURCE }); sub do_parse { my $slr = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); $slr->read( \'ABCD' ); return $slr->value(); } ## end sub do_parse my $value_ref; $value_ref = do_parse(); VALUE_TEST: { if ( ref $value_ref ne 'REF' ) { my $ref_type = ref $value_ref; Test::More::fail( qq{Parse result ref type is "$ref_type"; it needs to be "REF"}); last VALUE_TEST; } ## end if ( ref $value_ref ne 'REF' ) my $value = ${$value_ref}; if ( ref $value ne 'HASH' ) { my $ref_type = ref $value; Test::More::fail( qq{Parse value ref type is "$ref_type"; it needs to be "HASH"}); last VALUE_TEST; } ## end if ( ref $value ne 'HASH' ) my $expected_text = qq{rule 0: S ::= A B C D\nlocations: 0-4\n}; Test::More::is( $value->{text}, $expected_text, 'Parse ok?' ); } ## end VALUE_TEST: my $eval_ok; { local *do_S = *do_bail_with_message_if_A; $eval_ok = eval { $value_ref = do_parse(); 1 }; } my $actual_eval_error = $EVAL_ERROR // 'no eval error'; # grab it now to be safe Test::More::ok( ( not defined $eval_ok ), "bail with string argument happened" ); $actual_eval_error =~ s/\A User \s+ bailed \s+ at \s+ line \s+ \d+ [^\n]* \n//xms; Test::More::is( $actual_eval_error, '' . $bail_message . "\n", "bail with string argument" ); { local *do_S = *do_bail_with_object_if_A; $eval_ok = eval { $value_ref = do_parse(); 1 }; } $actual_eval_error = $EVAL_ERROR; my $eval_error_ref_type = ref $actual_eval_error; my $exception_value_desc = $eval_error_ref_type eq 'ARRAY' ? $actual_eval_error->[0] : "ref type of exception is $eval_error_ref_type"; Test::More::ok( ( not defined $eval_ok ), "bail with object argument happened" ); Test::More::is( $eval_error_ref_type, 'ARRAY', "bail with object argument ref type" ); Test::More::is( $exception_value_desc, $bail_message, "bail with object argument value" ); # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/naif.t0000444000000000000000000000305612342464706014411 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; # Small NAIF tests use strict; use warnings; use Test::More tests => 1; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; use Data::Dumper; my $grammar = Marpa::R2::Grammar->new( { start => 'start', actions => 'main', default_action => 'My_Actions::dwim', rules => [ [ start => [qw/x y/] ], ], } ); $grammar->precompute; my $rec = Marpa::R2::Recognizer->new( { grammar => $grammar } ); $rec->alternative('x',\undef, 1); $rec->earleme_complete; $rec->alternative('y',\"some", 1); $rec->earleme_complete; my $value_ref = $rec->value(); die if not defined $value_ref; Test::More::is_deeply( ${$value_ref}, [ undef, 'some' ], "Regression test of ref to undef as toke value" ); sub My_Actions::dwim { shift; return $_[0] if scalar @_ == 1; return [@_]; } # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/context.t0000444000000000000000000001070512342464707015160 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # NAIF semantics examples use 5.010; use strict; use warnings; use Test::More tests => 7; use English qw( -no_match_vars ); use Fatal qw( open close ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $trace_rules = q{}; # Marpa::R2::Display # name: Action context synopsis sub do_S { my ($action_object) = @_; my $rule_id = $Marpa::R2::Context::rule; my $grammar = $Marpa::R2::Context::grammar; my ( $lhs, @rhs ) = $grammar->rule($rule_id); $action_object->{text} = "rule $rule_id: $lhs ::= " . ( join q{ }, @rhs ) . "\n" . "locations: " . ( join q{-}, Marpa::R2::Context::location() ) . "\n"; return $action_object; } ## end sub do_S # Marpa::R2::Display::End # Marpa::R2::Display # name: Semantics bail synopsis my $bail_message = "This is a bail out message!"; sub do_bail_with_message_if_A { my ($action_object, $terminal) = @_; Marpa::R2::Context::bail($bail_message) if $terminal eq 'A'; } sub do_bail_with_object_if_A { my ($action_object, $terminal) = @_; Marpa::R2::Context::bail([$bail_message]) if $terminal eq 'A'; } # Marpa::R2::Display::End my @terminals = qw/A B C D/; my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ { lhs => 'S', rhs => \@terminals, action => 'main::do_S' }, ], symbols => { map { ( $_ => { terminal => 1 } ) } @terminals } } ); $grammar->precompute(); # Marpa::R2::Display # name: rule_ids() Synopsis my @rule_ids = $grammar->rule_ids(); # Marpa::R2::Display::End Test::More::is( ( join q{ }, @rule_ids ), '0', '$g->rule_ids() ok?' ); sub do_parse { my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); for my $terminal (@terminals) { $recce->read( $terminal, $terminal ); } return $recce->value(); } ## end sub do_parse my $value_ref; $value_ref = do_parse(); VALUE_TEST: { if ( ref $value_ref ne 'REF' ) { my $ref_type = ref $value_ref; Test::More::fail( qq{Parse result ref type is "$ref_type"; it needs to be "REF"}); last VALUE_TEST; } ## end if ( ref $value_ref ne 'REF' ) my $value = ${$value_ref}; if ( ref $value ne 'HASH' ) { my $ref_type = ref $value; Test::More::fail( qq{Parse value ref type is "$ref_type"; it needs to be "HASH"}); last VALUE_TEST; } ## end if ( ref $value ne 'HASH' ) my $expected_text = qq{rule 0: S ::= A B C D\nlocations: 0-4\n}; Test::More::is( $value->{text}, $expected_text, 'Parse ok?' ); } ## end VALUE_TEST: my $eval_ok; { local *do_S = *do_bail_with_message_if_A; $eval_ok = eval { $value_ref = do_parse(); 1 }; } my $actual_eval_error = $EVAL_ERROR // 'no eval error'; # grab it now to be safe Test::More::ok( ( not defined $eval_ok ), "bail with string argument happened" ); $actual_eval_error =~ s/\A User \s+ bailed \s+ at \s+ line \s+ \d+ [^\n]* \n//xms; Test::More::is( $actual_eval_error, '' . $bail_message . "\n", "bail with string argument" ); { local *do_S = *do_bail_with_object_if_A; $eval_ok = eval { $value_ref = do_parse(); 1 }; } $actual_eval_error = $EVAL_ERROR; my $eval_error_ref_type = ref $actual_eval_error; my $exception_value_desc = $eval_error_ref_type eq 'ARRAY' ? $actual_eval_error->[0] : "ref type of exception is $eval_error_ref_type"; Test::More::ok( ( not defined $eval_ok ), "bail with object argument happened" ); Test::More::is( $eval_error_ref_type, 'ARRAY', "bail with object argument ref type" ); Test::More::is( $exception_value_desc, $bail_message, "bail with object argument value" ); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/null_infinite1.t0000444000000000000000000000721312342464706016413 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Two rules which start with nullables, and cycle. use 5.010; use strict; use warnings; use Test::More tests => 3; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{-} if $v_count <= 0; my @vals = map { $_ // q{-} } @_; return '(' . join( q{;}, @vals ) . ')'; } ## end sub default_action sub rule_na { shift; return 'na(' . ( join q{;}, map { $_ // q{-} } @_ ) . ')'; } sub rule_Snf { shift; return 'Snf(' . ( join q{;}, ( map { $_ // q{-} } @_ ) ) . ')'; } sub rule_fa { shift; return 'fa(' . ( join q{;}, ( map { $_ // q{-} } @_ ) ) . ')'; } sub rule_fS { shift; return 'fS(' . ( join q{;}, ( map { $_ // q{-} } @_ ) ) . ')'; } ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', infinite_action => 'quiet', rules => [ { lhs => 'S', rhs => [qw/n f/], action => 'main::rule_Snf' }, { lhs => 'n', rhs => ['a'], action => 'main::rule_na' }, { lhs => 'n', rhs => [] }, { lhs => 'f', rhs => ['a'], action => 'main::rule_fa' }, { lhs => 'f', rhs => [] }, { lhs => 'f', rhs => ['S'], action => 'main::rule_fS' }, ], terminals => [qw(a)], default_action => 'main::default_action', } ); $grammar->precompute(); my @expected2 = qw{ Snf(-;fS(Snf(na(A);fS(Snf(-;fa(A)))))) Snf(-;fS(Snf(na(A);fS(Snf(na(A);-))))) Snf(-;fS(Snf(na(A);fa(A)))) Snf(na(A);fS(Snf(-;fa(A)))) Snf(na(A);fS(Snf(na(A);-))) Snf(na(A);fa(A)) }; my @expected3 = qw{ Snf(-;fS(Snf(na(A);fS(Snf(na(A);fS(Snf(-;fa(A)))))))) Snf(-;fS(Snf(na(A);fS(Snf(na(A);fS(Snf(na(A);-))))))) Snf(-;fS(Snf(na(A);fS(Snf(na(A);fa(A)))))) Snf(na(A);fS(Snf(na(A);fS(Snf(-;fa(A)))))) Snf(na(A);fS(Snf(na(A);fS(Snf(na(A);-))))) Snf(na(A);fS(Snf(na(A);fa(A)))) }; my @expected = ( [q{}], [ qw{ Snf(-;fa(A)) Snf(-;fS(Snf(na(A);-))) Snf(na(A);-) } ], \@expected2, \@expected3, ); for my $input_length ( 1 .. 3 ) { my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, max_parses => 99 } ); for my $token_ix ( 1 .. $input_length ) { $recce->read( 'a', 'A' ); } my $expected = $expected[$input_length]; my @values = (); while ( my $value_ref = $recce->value() ) { push @values, ${$value_ref}; } my $values = join "\n", sort @values; my $expected_values = join "\n", sort @{$expected}; # die if $values ne $expected_values; Marpa::R2::Test::is( $values, $expected_values, "value for input length $input_length" ); } ## end for my $input_length ( 1 .. 3 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_gia.t0000444000000000000000000003351212342464706014732 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Tests which require only grammar, input, and an output with no # semantics -- usually just an AST use 5.010; use strict; use warnings; use Test::More tests => 32; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; use Data::Dumper; my @tests_data = (); our $DEBUG = 0; # In crediting test, JDD = Jean-Damien Durand if (1) { my $glenn_grammar = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :default ::= action => ::array Start ::= Child DoubleColon Token DoubleColon ~ '::' Child ~ 'child' Token ~ word | word ':' word word ~ [\w]+ END_OF_SOURCE } ); my $input = 'child::book'; push @tests_data, [ $glenn_grammar, 'child::book', [ 'child', q{::}, 'book' ], 'Parse OK', 'Nate Glenn bug regression' ]; } ## end if (0) # Marpa::R2::Display # name: Case-insensitive characters examples # start-after-line: END_OF_SOURCE # end-before-line: '^END_OF_SOURCE$' if (1) { my $ic_grammar = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :default ::= action => ::array Start ::= Child DoubleColon Token DoubleColon ~ '::' Child ~ 'cHILd':i Token ~ word | word ':' word word ~ [\w]:ic + END_OF_SOURCE } ); # Marpa::R2::Display::End push @tests_data, [ $ic_grammar, 'ChilD::BooK', [ 'ChilD', q{::}, 'BooK' ], 'Parse OK', 'Case insensitivity test' ]; } ## end if (0) if (1) { my $durand_grammar1 = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :default ::= action => ::array start symbol is test test ::= TEST :lexeme ~ TEST TEST ~ '## Allowed in the input' NEWLINE WS ~ [ \t] WS_any ~ WS* POUND ~ '#' _NEWLINE ~ [\n] NOT_NEWLINE_any ~ [^\n]* NEWLINE ~ _NEWLINE COMMENT ~ WS_any POUND NOT_NEWLINE_any _NEWLINE :discard ~ COMMENT BLANKLINE ~ WS_any _NEWLINE :discard ~ BLANKLINE END_OF_SOURCE } ); push @tests_data, [ $durand_grammar1, <new( { source => \(<<'END_OF_SOURCE'), :default ::= action => ::array test ::= 'test input' NEWLINE WS ~ [ \t] WS_any ~ WS* POUND ~ '#' _NEWLINE ~ [\n] NOT_NEWLINE_any ~ [^\n]* NEWLINE ~ _NEWLINE COMMENT ~ WS_any POUND NOT_NEWLINE_any _NEWLINE :discard ~ COMMENT BLANKLINE ~ WS_any _NEWLINE :discard ~ BLANKLINE END_OF_SOURCE } ); push @tests_data, [ $durand_grammar2, <new( { source => \(<<'END_OF_SOURCE'), :default ::= action => ::array Script ::= '=' '/' 'dumb' _WhiteSpace ~ ' ' _LineTerminator ~ [\n] _SingleLineComment ~ '//' _SingleLineCommentCharsopt _SingleLineCommentChars ~ _SingleLineCommentChar _SingleLineCommentCharsopt _SingleLineCommentCharsopt ~ _SingleLineCommentChars _SingleLineCommentCharsopt ~ _SingleLineCommentChar ~ [^\n] _S ~ _WhiteSpace | _LineTerminator | _SingleLineComment S_MANY ~ _S+ :discard ~ S_MANY END_OF_SOURCE } ); push @tests_data, [ $durand_grammar3, < ::array product ::= sku (nl) name (nl) price price price (nl) sku ~ sku_0 '.' sku_0 sku_0 ~ [\d]+ price ~ price_0 ',' price_0 price_0 ~ [\d]+ nl ~ [\n] sp ~ [ ]+ :discard ~ sp :lexeme ~ forgiving => 1 name ~ [^\n]+ END_OF_SOURCE # Marpa::R2::Display::END my $input = <<'INPUT'; 130.12312 Descriptive line 1,10 1,10 1,30 INPUT my $slg = Marpa::R2::Scanless::G->new( { source => \$source } ); push @tests_data, [ $slg, $input, [ '130.12312', 'Descriptive line', '1,10', '1,10', '1,30' ], 'Parse OK', 'Test of forgiving token from Peter Stuifzand' ]; } # Test of LATM token from Ruslan Zakirov if (1) { # Marpa::R2::Display # name: latm adverb example # start-after-line: END_OF_SOURCE # end-before-line: '^END_OF_SOURCE$' my $source = <<'END_OF_SOURCE'; :default ::= action => ::array :start ::= content content ::= name ':' value name ~ [A-Za-z0-9-]+ value ~ [A-Za-z0-9:-]+ :lexeme ~ value latm => 1 END_OF_SOURCE # Marpa::R2::Display my $input = 'UID:urn:uuid:4fbe8971-0bc3-424c-9c26-36c3e1eff6b1'; my $expected_output = [ 'UID', ':', 'urn:uuid:4fbe8971-0bc3-424c-9c26-36c3e1eff6b1' ]; my $slg = Marpa::R2::Scanless::G->new( { source => \$source } ); push @tests_data, [ $slg, $input, $expected_output, 'Parse OK', 'Test of LATM token from Ruslan Zakirov' ]; } # Test of LATM token from Ruslan Zakirov # This time using the lexeme default statement if (1) { my $source = <<'END_OF_SOURCE'; lexeme default = latm => 1 :default ::= action => ::array :start ::= content content ::= name ':' value name ~ [A-Za-z0-9-]+ value ~ [A-Za-z0-9:-]+ END_OF_SOURCE my $input = 'UID:urn:uuid:4fbe8971-0bc3-424c-9c26-36c3e1eff6b1'; my $expected_output = [ 'UID', ':', 'urn:uuid:4fbe8971-0bc3-424c-9c26-36c3e1eff6b1' ]; my $slg = Marpa::R2::Scanless::G->new( { source => \$source } ); push @tests_data, [ $slg, $input, $expected_output, 'Parse OK', 'Test of LATM token using lexeme default statement' ]; } # Test of rank adverb if (1) { # Marpa::R2::Display # name: rank adverb example # start-after-line: END_OF_SOURCE # end-before-line: '^END_OF_SOURCE$' my $source = <<'END_OF_SOURCE'; lexeme default = latm => 1 :default ::= action => [name,values] :start ::= externals externals ::= external* action => [values] external ::= special action => ::first | unspecial action => ::first unspecial ::= ('I' 'am' 'special') words ('--' 'NOT!' ';') rank => 1 special ::= words (';') rank => -1 words ::= word* action => [values] :discard ~ whitespace whitespace ~ [\s]+ word ~ [\w!-]+ END_OF_SOURCE my $input = <<'END_OF_INPUT'; I am special so very special -- NOT!; I am special and nothing is going to change that; END_OF_INPUT # Marpa::R2::Display my $expected_output = [ [ 'unspecial', [qw(so very special)] ], [ 'special', [qw(I am special and nothing is going to change that)], ] ]; my $slg = Marpa::R2::Scanless::G->new( { source => \$source } ); push @tests_data, [ $slg, $input, $expected_output, 'Parse OK', 'Test of rank adverb for display' ]; } # Test of rule array item descriptor for action adverb # todo: test by converting rule and lhs ID's to names # based on $slg->symbol_is_lexeme(symbol_id) -- to be written if (1) { my $source = <<'END_OF_SOURCE'; :default ::= action => [lhs, rule, values] lexeme default = action => [lhs, rule, value] start ::= number1 number2 number1 ::= number2 ::= ~ '42' ~ '43' END_OF_SOURCE my $input = '4243'; my $expected_output = [ 1, 0, [ 2, 1, [ 4, undef, '42' ] ], [ 3, 2, [ 5, undef, '43' ] ] ]; my $slg = Marpa::R2::Scanless::G->new( { source => \$source } ); push @tests_data, [ $slg, $input, $expected_output, 'Parse OK', 'Test of rule array item descriptor for action adverb' ]; } # Test of 'symbol', 'name' array item descriptors if (1) { # Marpa::R2::Display # name: symbol, name array descriptor example # start-after-line: END_OF_SOURCE # end-before-line: '^END_OF_SOURCE$' my $source = <<'END_OF_SOURCE'; :default ::= action => [symbol, name, values] lexeme default = action => [symbol, name, value] start ::= number1 number2 name => top number1 ::= name => 'number 1' number2 ::= name => 'number 2' ~ '42' ~ '43' END_OF_SOURCE # Marpa::R2::Display::End my $input = '4243'; my $expected_output = [ 'start', 'top', [ 'number1', 'number 1', [ 'forty two', 'forty two', '42' ] ], [ 'number2', 'number 2', [ 'forty three', 'forty three', '43' ] ] ]; my $slg = Marpa::R2::Scanless::G->new( { source => \$source } ); push @tests_data, [ $slg, $input, $expected_output, 'Parse OK', 'Test of rule array item descriptor for action adverb' ]; } ### Test of 'inaccessible is ok' if (1) { # Marpa::R2::Display # name: inaccessible is ok statement # start-after-line: END_OF_SOURCE # end-before-line: '^END_OF_SOURCE$' my $source = <<'END_OF_SOURCE'; inaccessible is ok by default :default ::= action => [values] start ::= stuff* stuff ::= a | b a ::= x action => ::first b ::= x action => ::first c ::= x action => ::first x ::= 'x' END_OF_SOURCE # Marpa::R2::Display::End my $input = 'xx'; my $expected_output = [ [ [ 'x' ] ], [ [ 'x' ] ] ]; my $slg = Marpa::R2::Scanless::G->new( { source => \$source } ); push @tests_data, [ $slg, $input, $expected_output, 'Parse OK', qq{Test of "Inaccessible is ok"} ]; } if (1) { my $source = <<'END_OF_SOURCE'; inaccessible is ok by default :default ::= action => ::first start ::= !START! start1 ::= X start2 ::= Y X ~ 'X' Y ~ 'X' END_OF_SOURCE my $input = 'X'; my $expected_output = 'X'; for my $this_start (qw/start1 start2/) { my $this_source = $source; $this_source =~ s/!START!/$this_start/; my $slg = Marpa::R2::Scanless::G->new( { source => \$this_source } ); push @tests_data, [ $slg, $input, $expected_output, 'Parse OK', qq{Test of changing start symbols: <$this_start>} ]; } ## end for my $this_start (qw/start1 start2/) } if (1) { my $source = <<'END_OF_SOURCE'; :default ::= action => ::first dual_start ::= start1 name => 'first start rule' dual_start ::= start2 name => 'second start rule' start1 ::= X start2 ::= Y X ~ 'X' Y ~ 'Y' END_OF_SOURCE my $input = 'X'; my $expected_output = 'X'; my $slg = Marpa::R2::Scanless::G->new( { source => \$source } ); # Marpa::R2::Display # name: $slg->start_symbol_id() example my $start_id = $slg->start_symbol_id(); # Marpa::R2::Display::End Test::More::is( $start_id, 0, q{Test of $slg->start_symbol_id()} ); my @rule_names = (); # Marpa::R2::Display # name: $slg->rule_name() example push @rule_names, $slg->rule_name($_) for $slg->rule_ids(); # Marpa::R2::Display::End my $rule_names = join q{:}, @rule_names; Test::More::is( $rule_names, 'first start rule:second start rule:start1:start2:[:start]', q{Test of $slg->rule_name()} ); push @tests_data, [ $slg, $input, $expected_output, 'Parse OK', qq{Test of alternative as start rule} ]; } ## end if (0) TEST: for my $test_data (@tests_data) { my ( $grammar, $test_string, $expected_value, $expected_result, $test_name ) = @{$test_data}; my ( $actual_value, $actual_result ) = my_parser( $grammar, $test_string ); Test::More::is( Data::Dumper::Dumper( \$actual_value ), Data::Dumper::Dumper( \$expected_value ), qq{Value of $test_name} ); Test::More::is( $actual_result, $expected_result, qq{Result of $test_name} ); } ## end TEST: for my $test_data (@tests_data) sub my_parser { my ( $grammar, $string ) = @_; my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); if ( not defined eval { $recce->read( \$string ); 1 } ) { say $EVAL_ERROR if $DEBUG; my $abbreviated_error = $EVAL_ERROR; chomp $abbreviated_error; return 'No parse', $abbreviated_error; } ## end if ( not defined eval { $recce->read( \$string ); 1 ...}) my $value_ref = $recce->value(); if ( not defined $value_ref ) { return 'No parse', 'Input read to end but no parse'; } return [ return ${$value_ref}, 'Parse OK' ]; } ## end sub my_parser # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/thin_deprec.t0000444000000000000000000002310212342464707015753 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Testing using deprecated methods of # the thin interface use 5.010; use strict; use warnings; use Test::More tests => 13; use lib 'inc'; use Marpa::R2::Test; use English qw( -no_match_vars ); use Fatal qw( close open ); use Marpa::R2; my $grammar = Marpa::R2::Thin::G->new( { if => 1 } ); $grammar->force_valued(); my $symbol_S = $grammar->symbol_new(); my $symbol_E = $grammar->symbol_new(); $grammar->start_symbol_set($symbol_S); my $symbol_op = $grammar->symbol_new(); my $symbol_number = $grammar->symbol_new(); my $start_rule_id = $grammar->rule_new( $symbol_S, [$symbol_E] ); my $op_rule_id = $grammar->rule_new( $symbol_E, [ $symbol_E, $symbol_op, $symbol_E ] ); my $number_rule_id = $grammar->rule_new( $symbol_E, [$symbol_number] ); $grammar->precompute(); my $recce = Marpa::R2::Thin::R->new($grammar); $recce->start_input(); # The numbers from 1 to 3 are themselves -- # that is, they index their own token value. # Important: zero cannot be itself! my @token_values = ( 0 .. 3 ); my $zero = -1 + push @token_values, 0; my $minus_token_value = -1 + push @token_values, q{-}; my $plus_token_value = -1 + push @token_values, q{+}; my $multiply_token_value = -1 + push @token_values, q{*}; $recce->alternative( $symbol_number, 2, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_op, $minus_token_value, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_number, $zero, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_op, $multiply_token_value, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_number, 3, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_op, $plus_token_value, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_number, 1, 1 ); $recce->earleme_complete(); my $latest_earley_set_ID = $recce->latest_earley_set(); my $bocage = Marpa::R2::Thin::B->new( $recce, $latest_earley_set_ID ); my $order = Marpa::R2::Thin::O->new($bocage); my $tree = Marpa::R2::Thin::T->new($order); my @actual_values = (); while ( $tree->next() ) { my $valuator = Marpa::R2::Thin::V->new($tree); my @stack = (); STEP: while (1) { my ( $type, @step_data ) = $valuator->step(); last STEP if not defined $type; if ( $type eq 'MARPA_STEP_TOKEN' ) { my ( undef, $token_value_ix, $arg_n ) = @step_data; $stack[$arg_n] = $token_values[$token_value_ix]; next STEP; } if ( $type eq 'MARPA_STEP_RULE' ) { my ( $rule_id, $arg_0, $arg_n ) = @step_data; if ( $rule_id == $start_rule_id ) { my ( $string, $value ) = @{ $stack[$arg_n] }; $stack[$arg_0] = "$string == $value"; next STEP; } if ( $rule_id == $number_rule_id ) { my $number = $stack[$arg_0]; $stack[$arg_0] = [ $number, $number ]; next STEP; } if ( $rule_id == $op_rule_id ) { my $op = $stack[ $arg_0 + 1 ]; my ( $right_string, $right_value ) = @{ $stack[$arg_n] }; my ( $left_string, $left_value ) = @{ $stack[$arg_0] }; my $value; my $text = '(' . $left_string . $op . $right_string . ')'; if ( $op eq q{+} ) { $stack[$arg_0] = [ $text, $left_value + $right_value ]; next STEP; } if ( $op eq q{-} ) { $stack[$arg_0] = [ $text, $left_value - $right_value ]; next STEP; } if ( $op eq q{*} ) { $stack[$arg_0] = [ $text, $left_value * $right_value ]; next STEP; } die "Unknown op: $op"; } ## end if ( $rule_id == $op_rule_id ) die "Unknown rule $rule_id"; } ## end if ( $type eq 'MARPA_STEP_RULE' ) die "Unexpected step type: $type"; } ## end STEP: while (1) push @actual_values, $stack[0]; } ## end while ( $tree->next() ) my %expected_value = ( '(2-(0*(3+1))) == 2' => 1, '(((2-0)*3)+1) == 7' => 1, '((2-(0*3))+1) == 3' => 1, '((2-0)*(3+1)) == 8' => 1, '(2-((0*3)+1)) == 1' => 1, ); my $i = 0; for my $actual_value (@actual_values) { if ( defined $expected_value{$actual_value} ) { delete $expected_value{$actual_value}; Test::More::pass("Expected Value $i: $actual_value"); } else { Test::More::fail("Unexpected Value $i: $actual_value"); } $i++; } ## end for my $actual_value (@actual_values) # For the error methods, start clean, # with a new, trivial grammar $grammar = $recce = $bocage = $order = $tree = undef; $grammar = Marpa::R2::Thin::G->new( { if => 1 } ); $grammar->force_valued(); my ( $error_code, $error_description ) = $grammar->error(); my @error_names = Marpa::R2::Thin::error_names(); my $error_name = $error_names[$error_code]; Test::More::is( $error_code, 0, 'Grammar error code' ); Test::More::is( $error_name, 'MARPA_ERR_NONE', 'Grammar error name' ); Test::More::is( $error_description, 'No error', 'Grammar error description' ); $symbol_S = $grammar->symbol_new(); my $symbol_a = $grammar->symbol_new(); my $symbol_sep = $grammar->symbol_new(); $grammar->start_symbol_set($symbol_S); my $sequence_rule_id = $grammar->sequence_new( $symbol_S, $symbol_a, { separator => $symbol_sep, proper => 0, min => 1 } ); $grammar->precompute(); my @events; my $event_ix = $grammar->event_count(); while ( $event_ix-- ) { my ( $event_type, $value ) = $grammar->event( $event_ix++ ); } $recce = Marpa::R2::Thin::R->new($grammar); $recce->ruby_slippers_set(1); $recce->start_input(); $recce->alternative( $symbol_a, 1, 1 ); $recce->earleme_complete(); my @terminals = $recce->terminals_expected(); Test::More::is( ( scalar @terminals ), 1, 'count of terminals expected' ); Test::More::is( $terminals[0], $symbol_sep, 'expected terminal' ); my $report; my $ordinal = $recce->latest_earley_set(); $recce->progress_report_start($ordinal); ITEM: while (1) { my ( $rule_id, $dot_position, $origin ) = $recce->progress_item(); last ITEM if not defined $rule_id; push @{$report}, [ $rule_id, $dot_position, $origin ]; } $recce->progress_report_finish(); Test::More::is( ( join q{ }, map { @{$_} } @{$report} ), '0 -1 0 0 0 0', 'progress report' ); $recce->alternative( $symbol_sep, 1, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_a, 1, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_sep, 1, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_a, 1, 1 ); $recce->earleme_complete(); $latest_earley_set_ID = $recce->latest_earley_set(); $bocage = Marpa::R2::Thin::B->new( $recce, $latest_earley_set_ID ); $order = Marpa::R2::Thin::O->new($bocage); $tree = Marpa::R2::Thin::T->new($order); $tree->next(); my $valuator = Marpa::R2::Thin::V->new($tree); my $locations_report = q{}; STEP: for ( ;; ) { my ( $type, @step_data ) = $valuator->step(); last STEP if not defined $type; $type = $valuator->step_type(); my ( $start, $end ) = $valuator->location(); if ( $type eq 'MARPA_STEP_RULE' ) { my ($rule_id) = @step_data; $locations_report .= "Rule $rule_id is from $start to $end\n"; } if ( $type eq 'MARPA_STEP_TOKEN' ) { my ($token_id) = @step_data; $locations_report .= "Token $token_id is from $start to $end\n"; } if ( $type eq 'MARPA_STEP_NULLING_SYMBOL' ) { my ($symbol_id) = @step_data; $locations_report .= "Nulling symbol $symbol_id is from $start to $end\n"; } } ## end STEP: for ( ;; ) Test::More::is( $locations_report, <<'EXPECTED', 'Step locations' ); Token 1 is from 0 to 1 Token 2 is from 1 to 2 Token 1 is from 2 to 3 Token 2 is from 3 to 4 Token 1 is from 4 to 5 Rule 0 is from 0 to 5 EXPECTED { my $symbol_count = 0; my @unvalued_symbols = (); for ( my $symbol_id = 0; $symbol_id <= $grammar->highest_symbol_id(); $symbol_id++ ) { $grammar->throw_set(0); my $result = $grammar->symbol_is_start($symbol_id); $grammar->throw_set(1); next SYMBOL if $result == -1; # well-formed but non-existent if ($result < 0) { my ( $error_code, $error_description ) = $grammar->error(); die "symbol_is_start($symbol_id) failed ($error_code) $error_description"; } $symbol_count++; push @unvalued_symbols, $symbol_id if !$grammar->symbol_is_valued($symbol_id); } ## end for ( my $symbol_id = 0; $symbol_id <= $grammar->...) my $unvalued_desc = ( scalar @unvalued_symbols ) ? ( join q{ }, @unvalued_symbols ) : 'none'; Test::More::ok( ( $unvalued_desc eq 'none' ), "Unvalued symbols: $unvalued_desc of $symbol_count" ); } # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/infinite.t0000444000000000000000000001242012342464707015275 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # A grammar with cycles use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Fatal qw(open close chdir); use Test::More tests => 6; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; return undef if not scalar @_; return join q{ }, grep { defined $_ } @_; } ## use critic package Test_Grammar; # Formatted by Data::Dumper, which disagrees with # perltidy and perlcritic about things #<<< no perltidy $Test_Grammar::MARPA_OPTIONS_1 = [ { 'default_action' => 'main::default_action', 'rules' => [ { 'lhs' => 's', 'rhs' => ['s'] } ], 'start' => 's', 'terminals' => ['s'], } ]; $Test_Grammar::MARPA_OPTIONS_2 = [ { 'default_action' => 'main::default_action', 'rules' => [ { 'lhs' => 's', 'rhs' => [ 'a' ] }, { 'lhs' => 'a', 'rhs' => [ 's' ] } ], 'start' => 's', 'terminals' => [ 'a' ], } ]; $Test_Grammar::MARPA_OPTIONS_8 = [ { default_action => 'main::default_action', rules => [ { 'lhs' => 'S', 'rhs' => [ 'A' ] }, { 'lhs' => 'A', 'rhs' => [ 'B', 'T', 'U' ] }, { 'lhs' => 'B', 'rhs' => [ 'V', 'C' ] }, { 'lhs' => 'C', 'rhs' => [ 'W', 'D', 'X' ] }, { 'lhs' => 'D', 'rhs' => [ 'E' ] }, { 'lhs' => 'E', 'rhs' => [ 'S' ] }, { 'lhs' => 'T', 'rhs' => [] }, { 'lhs' => 'U', 'rhs' => [] }, { 'lhs' => 'V', 'rhs' => [] }, { 'lhs' => 'W', 'rhs' => [] }, { 'lhs' => 'X', 'rhs' => [] }, { lhs=>'E', rhs=>['e'] }, { lhs=>'T', rhs=>['t'] }, { lhs=>'U', rhs=>['u'] }, { lhs=>'V', rhs=>['v'] }, { lhs=>'W', rhs=>['w'] }, { lhs=>'X', rhs=>['x'] } ], 'start' => 'S', 'terminals' => [ 'e', 't', 'u', 'v', 'w', 'x' ], } ]; #>>> ## use critic package main; my $cycle1_test = [ 'cycle1', $Test_Grammar::MARPA_OPTIONS_1, [ [ [ 's', \'1' ] ] ], '1', <<'EOS' Cycle found involving rule: 0: s -> s EOS ]; my $cycle2_test = [ 'cycle2', $Test_Grammar::MARPA_OPTIONS_2, [ [ [ 'a', \'1' ] ] ], '1', <<'EOS' Cycle found involving rule: 0: s -> a Cycle found involving rule: 1: a -> s EOS ]; my @cycle8_tokens = ( [ [ 'e', \'1' ], [ 'v', \'1' ], [ 'w', \'1' ] ] ); push @cycle8_tokens, map { ( [ [ 'e', \$_ ], [ 't', \$_ ], [ 'u', \$_ ], [ 'v', \$_ ], [ 'w', \$_ ], [ 'x', \$_ ] ], ) } qw( 2 3 4 5 6 ); my $cycle8_test = [ 'cycle8', $Test_Grammar::MARPA_OPTIONS_8, \@cycle8_tokens, '1 2 3 4 5 6', <<'EOS' Cycle found involving rule: 0: S -> A Cycle found involving rule: 1: A -> B T U Cycle found involving rule: 2: B -> V C Cycle found involving rule: 3: C -> W D X Cycle found involving rule: 4: D -> E Cycle found involving rule: 5: E -> S EOS ]; for my $test_data ( $cycle1_test, $cycle2_test, $cycle8_test ) { my ( $test_name, $marpa_options, $input, $expected, $expected_trace ) = @{$test_data}; my $trace = q{}; open my $MEMORY, '>', \$trace; my $grammar = Marpa::R2::Grammar->new( { infinite_action => 'warn', trace_file_handle => $MEMORY, }, @{$marpa_options}, ); $grammar->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); for my $earleme_input ( @{$input} ) { for my $token ( @{$earleme_input} ) { $recce->alternative(@{$token}); } $recce->earleme_complete(); } my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; close $MEMORY; Marpa::R2::Test::is( $value, $expected, "$test_name result" ); Marpa::R2::Test::is( $trace, $expected_trace, "$test_name trace" ); } ## end for my $test_data ( $cycle1_test, $cycle2_test, $cycle8_test) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/curly.t0000444000000000000000000001167412342464707014640 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use warnings; use strict; use English qw( -no_match_vars ); use Getopt::Long (); use Test::More ( import => [] ); use lib 'pperl'; BEGIN { my $PPI_problem; CHECK_PPI: { if ( not eval { require PPI } ) { $PPI_problem = "PPI not installed: $EVAL_ERROR"; last CHECK_PPI; } if ( not PPI->VERSION(1.206) ) { $PPI_problem = 'PPI 1.206 not installed'; } } ## end CHECK_PPI: if ($PPI_problem) { Test::More::plan skip_all => $PPI_problem; } else { Test::More::plan tests => 8; } } ## end BEGIN use Marpa::R2; use Marpa::R2::Perl; use lib 'inc'; use Marpa::R2::Test; # Run in utility mode? my $utility = 0; die if not Getopt::Long::GetOptions( utility => \$utility ); my %hash; my %codeblock; my @tests; if ($utility) { my $string = do { local $RS = undef; }; @tests = ( [ $string, q{} ] ); } else { @tests = ( [ '{42;{1,2,3;4}}', << 'END_OF_RESULT', 1 Code block at line 1, column 1 Code block at line 1, column 5 END_OF_RESULT ], [ '{42;{1,2,3,4}}', << 'END_OF_RESULT', 2 Code block at line 1, column 1 Code block at line 1, column 5 Hash at line 1, column 5 END_OF_RESULT ], [ '{42;{;1,2,3;4}}', << 'END_OF_RESULT', 1 Code block at line 1, column 1 Code block at line 1, column 5 END_OF_RESULT ], [ '{42;+{1,2,3,4}}', << 'END_OF_RESULT', 1 Code block at line 1, column 1 Hash at line 1, column 6 END_OF_RESULT ], ); } ## end else [ if ($utility) ] my $parser = Marpa::R2::Perl->new( { closures => {} } ); TEST: for my $test (@tests) { my ( $string, $expected, $expected_parse_count ) = @{$test}; $parser = $parser->read( \$string ); my @values = $parser->eval(); my $recce = $parser->{recce}; my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR]; my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C]; my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES]; for my $earley_set_id ( 0 .. $recce->latest_earley_set() ) { my $progress_report = $recce->progress($earley_set_id); ITEM: for my $progress_item ( @{$progress_report} ) { my ( $rule_id, $position, $origin_earley_set_id ) = @{$progress_item}; last ITEM if not defined $rule_id; next ITEM if $position >= 0; $position = $grammar_c->rule_length($rule_id); # Marpa::R2::Display # name: earleme() Synopsis my $origin_earleme = $recce->earleme($origin_earley_set_id); # Marpa::R2::Display::End my $rule = $rules->[$rule_id]; my $rule_name = $rule->[Marpa::R2::Internal::Rule::NAME]; next ITEM if not defined $rule_name; my $blocktype = $rule_name eq 'anon_hash' ? 'hash' : $rule_name eq 'block' ? 'code' : $rule_name eq 'mblock' ? 'code' : undef; next ITEM if not defined $blocktype; my $PPI_tokens = $parser->{PPI_tokens}; my $earleme_to_token = $parser->{earleme_to_PPI_token}; my $token = $PPI_tokens->[ $earleme_to_token->[$origin_earleme] ]; my $location = 'line ' . $token->logical_line_number() . q{, column } . $token->column_number; $hash{$location}++ if $blocktype eq 'hash'; $codeblock{$location}++ if $blocktype eq 'code'; } ## end for my $progress_item ( @{$progress_report} ) } ## end for my $earley_set_id ( 0 .. $recce->latest_earley_set...) Marpa::R2::Test::is( ( scalar @values ), $expected_parse_count, 'Count of values' ); my @result; for my $location ( sort keys %hash ) { push @result, "Hash at $location\n"; } for my $location ( sort keys %codeblock ) { push @result, "Code block at $location\n"; } my $result = join q{}, sort @result; if ($utility) { say $result or die 'say builtin failed'; } else { Marpa::R2::Test::is( $result, $expected, qq{Test of "$string"} ); } %hash = (); %codeblock = (); } ## end for my $test (@tests) # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/counter.t0000444000000000000000000000606012342464707015152 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # This uses an ambiguous grammar to implement a binary # counter. A very expensive way to do it, but a # good test of the ranking logic. use 5.010; use strict; use warnings; use Test::More tests => 32; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; sub zero { return '0' } sub one { return '1' } sub start_rule_action { shift; return join q{}, @_; } ## use critic sub gen_grammar { my ($is_count_up) = @_; my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ { lhs => 'S', rhs => [qw/digit digit digit digit/], action => 'main::start_rule_action' }, { lhs => 'digit', rhs => ['zero'], rank => $is_count_up ? 1 : 0, action => 'main::zero' }, { lhs => 'digit', rhs => ['one'], rank => $is_count_up ? 0 : 1, action => 'main::one' }, { lhs => 'one', rhs => ['t'], }, { lhs => 'zero', rhs => ['t'], }, ], terminals => [qw(t)], } ); return $grammar->precompute(); } ## end sub gen_grammar my @counting_up = qw{ 0000 0001 0010 0011 0100 0101 0110 0111 1000 1001 1010 1011 1100 1101 1110 1111 }; my @counting_down = reverse @counting_up; for my $is_count_up ( 1, 0 ) { my $count = $is_count_up ? ( \@counting_up ) : ( \@counting_down ); my $direction_desc = $is_count_up ? 'up' : 'down'; my $recce = Marpa::R2::Recognizer->new( { grammar => gen_grammar($is_count_up), ranking_method => 'rule' } ); my $input_length = 4; for ( 1 .. $input_length ) { $recce->read('t'); } my $i = 0; while ( my $result = $recce->value() ) { my $got = ${$result}; my $expected = reverse $count->[$i]; Test::More::is( $got, $expected, "counting $direction_desc $i" ); $i++; } ## end while ( my $result = $recce->value() ) } ## end for my $is_count_up ( 1, 0 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/timeflies.t0000444000000000000000000001207512342464706015456 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # This example is from Ralf Muschall, who clearly knows English # grammar better than most native speakers. I've reworked the # terminology to follow _A Comprehensive Grammar of the English # Language_, by Quirk, Greenbaum, Leech and Svartvik. My edition # was the "Seventh (corrected) impression 1989". # # When it is not a verb, I treat "like" # as a preposition in an adjunct of manner, # as per 8.79, p. 557; 9.4, pp. 661; and 9.48, pp. 698-699. # # The saying "time flies like an arrow; fruit flies like a banana" # is attributed to Groucho Marx, but there is no reason to believe # he ever said it. Apparently, the saying # first appeared on the Usenet on net.jokes in 1982. # I've documented this whole thing on Wikipedia: # http://en.wikipedia.org/wiki/Time_flies_like_an_arrow # # The permalink is: # http://en.wikipedia.org/w/index.php?title=Time_flies_like_an_arrow&oldid=311163283 use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Test::More tests => 1; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub do_sva_sentence { return "sva($_[1];$_[2];$_[3])" } sub do_svo_sentence { return "svo($_[1];$_[2];$_[3])" } sub do_adjunct { return "adju($_[1];$_[2])" } sub do_adjective { return "adje($_[1])" } sub do_qualified_subject { return "s($_[1];$_[2])" } sub do_bare_subject { return "s($_[1])" } sub do_noun { return "n($_[1])" } sub do_verb { return "v($_[1])" } sub do_object { return "o($_[1];$_[2])" } sub do_article { return "art($_[1])" } sub do_preposition { return "pr($_[1])" } ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'sentence', actions => 'main', rules => [ [ 'sentence', [qw(subject verb adjunct)], 'do_sva_sentence' ], [ 'sentence', [qw(subject verb object)], 'do_svo_sentence' ], [ 'adjunct', [qw(preposition object)], 'do_adjunct' ], [ 'adjective', [qw(adjective_noun_lex)], 'do_adjective' ], [ 'subject', [qw(adjective noun)], 'do_qualified_subject' ], [ 'subject', [qw(noun)], 'do_bare_subject' ], [ 'noun', [qw(adjective_noun_lex)], 'do_noun' ], [ 'verb', [qw(verb_lex)], 'do_verb' ], [ 'object', [qw(article noun)], 'do_object' ], [ 'article', [qw(article_lex)], 'do_article' ], [ 'preposition', [qw(preposition_lex)], 'do_preposition' ], ], } ); my $expected = <<'EOS'; sva(s(n(fruit));v(flies);adju(pr(like);o(art(a);n(banana)))) sva(s(n(time));v(flies);adju(pr(like);o(art(an);n(arrow)))) svo(s(adje(fruit);n(flies));v(like);o(art(a);n(banana))) svo(s(adje(time);n(flies));v(like);o(art(an);n(arrow))) EOS my @actual = (); $grammar->precompute(); my %lexical_class = ( 'preposition_lex' => 'like', 'verb_lex' => 'like flies', 'adjective_noun_lex' => 'fruit banana time arrow flies', 'article_lex' => 'a an', ); my %vocabulary = (); for my $lexical_class (keys %lexical_class) { my $words = $lexical_class{$lexical_class}; for my $word ( split q{ }, $words ) { push @{ $vocabulary{$word} }, $lexical_class; } } ## end for my $lexical_class (%lexical_class) for my $data ( 'time flies like an arrow', 'fruit flies like a banana' ) { my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); die 'Failed to create recognizer' if not $recce; for my $word ( split q{ }, $data ) { # Marpa::R2::Display # name: Recognizer exhausted Synopsis $recce->exhausted() and die 'Recognizer exhausted'; # Marpa::R2::Display::End for my $type ( @{ $vocabulary{$word} } ) { $recce->alternative( $type, \$word, 1 ) or die 'Recognition failed'; } $recce->earleme_complete(); } ## end for my $word ( split q{ }, $data ) # Marpa::R2::Display # name: Recognizer end_input Synopsis $recce->end_input(); # Marpa::R2::Display::End while ( defined( my $value_ref = $recce->value() ) ) { my $value = $value_ref ? ${$value_ref} : 'No parse'; push @actual, $value; } } ## end for my $data ( 'time flies like an arrow', ...) Marpa::R2::Test::is( ( join "\n", sort @actual ) . "\n", $expected, 'Ambiguous English sentences' ); 1; # In case used as "do" file Marpa-R2-2.086000~dfsg/t/equation.t0000444000000000000000000002030312342464707015314 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # An ambiguous equation use 5.010; use strict; use warnings; use Test::More tests => 11; use lib 'inc'; use Marpa::R2::Test; use English qw( -no_match_vars ); use Fatal qw( close open ); use Marpa::R2; ## no critic (InputOutput::RequireBriefOpen) open my $original_stdout, q{>&STDOUT}; ## use critic sub save_stdout { my $save; my $save_ref = \$save; close STDOUT; open STDOUT, q{>}, $save_ref; return $save_ref; } ## end sub save_stdout sub restore_stdout { close STDOUT; open STDOUT, q{>&}, $original_stdout; return 1; } ## no critic (Subroutines::RequireArgUnpacking, ErrorHandling::RequireCarping) sub do_op { shift; my ( $right_string, $right_value ) = ( $_[2] =~ /^(.*)==(.*)$/xms ); my ( $left_string, $left_value ) = ( $_[0] =~ /^(.*)==(.*)$/xms ); my $op = $_[1]; my $value; if ( $op eq q{+} ) { $value = $left_value + $right_value; } elsif ( $op eq q{*} ) { $value = $left_value * $right_value; } elsif ( $op eq q{-} ) { $value = $left_value - $right_value; } else { die "Unknown op: $op"; } return '(' . $left_string . $op . $right_string . ')==' . $value; } ## end sub do_op sub number { shift; my $v0 = pop @_; return $v0 . q{==} . $v0; } sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . join( q{;}, @_ ) . ')'; } ## end sub default_action my $grammar = Marpa::R2::Grammar->new( { start => 'E', actions => 'main', rules => [ [ 'E', [qw/E Op E/], 'do_op' ], [ 'E', [qw/Number/], 'number' ], ], default_action => 'default_action', } ); $grammar->precompute(); my $actual_ref; $actual_ref = save_stdout(); # Marpa::R2::Display # name: show_symbols Synopsis print $grammar->show_symbols() or die "print failed: $ERRNO"; # Marpa::R2::Display::End restore_stdout(); Marpa::R2::Test::is( ${$actual_ref}, <<'END_SYMBOLS', 'Ambiguous Equation Symbols' ); 0: E 1: Op, terminal 2: Number, terminal END_SYMBOLS $actual_ref = save_stdout(); # Marpa::R2::Display # name: show_rules Synopsis print $grammar->show_rules() or die "print failed: $ERRNO"; # Marpa::R2::Display::End restore_stdout(); Marpa::R2::Test::is( ${$actual_ref}, <<'END_RULES', 'Ambiguous Equation Rules' ); 0: E -> E Op E 1: E -> Number END_RULES $actual_ref = save_stdout(); print $grammar->show_ahms() or die "print failed: $ERRNO"; restore_stdout(); Marpa::R2::Test::is( ${$actual_ref}, <<'EOS', 'Ambiguous Equation AHMs' ); AHM 0: postdot = "E" E ::= . E Op E AHM 1: postdot = "Op" E ::= E . Op E AHM 2: postdot = "E" E ::= E Op . E AHM 3: completion E ::= E Op E . AHM 4: postdot = "Number" E ::= . Number AHM 5: completion E ::= Number . AHM 6: postdot = "E" E['] ::= . E AHM 7: completion E['] ::= E . EOS $actual_ref = save_stdout(); # Marpa::R2::Display # name: show_problems Synopsis print $grammar->show_problems() or die "print failed: $ERRNO"; # Marpa::R2::Display::End Marpa::R2::Test::is( ${$actual_ref}, "Grammar has no problems\n", 'Ambiguous Equation Problems' ); restore_stdout(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); $recce->read( 'Number', 2 ); $recce->read( 'Op', q{-} ); $recce->read( 'Number', 0 ); $recce->read( 'Op', q{*} ); $recce->read( 'Number', 3 ); $recce->read( 'Op', q{+} ); $recce->read( 'Number', 1 ); $actual_ref = save_stdout(); print $recce->show_earley_sets() or die "print failed: $ERRNO"; my $expected_earley_sets = <<'END_OF_EARLEY_SETS'; Last Completed: 7; Furthest: 7 Earley Set 0 ahm6: R2:0@0-0 R2:0: E['] ::= . E ahm0: R0:0@0-0 R0:0: E ::= . E Op E ahm4: R1:0@0-0 R1:0: E ::= . Number Earley Set 1 ahm5: R1$@0-1 R1$: E ::= Number . [c=R1:0@0-0; s=Number; t=\2] ahm1: R0:1@0-1 R0:1: E ::= E . Op E [p=R0:0@0-0; c=R1$@0-1] ahm7: R2$@0-1 R2$: E['] ::= E . [p=R2:0@0-0; c=R1$@0-1] Earley Set 2 ahm2: R0:2@0-2 R0:2: E ::= E Op . E [c=R0:1@0-1; s=Op; t=\'-'] ahm0: R0:0@2-2 R0:0: E ::= . E Op E ahm4: R1:0@2-2 R1:0: E ::= . Number Earley Set 3 ahm5: R1$@2-3 R1$: E ::= Number . [c=R1:0@2-2; s=Number; t=\0] ahm1: R0:1@2-3 R0:1: E ::= E . Op E [p=R0:0@2-2; c=R1$@2-3] ahm3: R0$@0-3 R0$: E ::= E Op E . [p=R0:2@0-2; c=R1$@2-3] ahm1: R0:1@0-3 R0:1: E ::= E . Op E [p=R0:0@0-0; c=R0$@0-3] ahm7: R2$@0-3 R2$: E['] ::= E . [p=R2:0@0-0; c=R0$@0-3] Earley Set 4 ahm2: R0:2@0-4 R0:2: E ::= E Op . E [c=R0:1@0-3; s=Op; t=\'*'] ahm2: R0:2@2-4 R0:2: E ::= E Op . E [c=R0:1@2-3; s=Op; t=\'*'] ahm0: R0:0@4-4 R0:0: E ::= . E Op E ahm4: R1:0@4-4 R1:0: E ::= . Number Earley Set 5 ahm5: R1$@4-5 R1$: E ::= Number . [c=R1:0@4-4; s=Number; t=\3] ahm1: R0:1@4-5 R0:1: E ::= E . Op E [p=R0:0@4-4; c=R1$@4-5] ahm3: R0$@2-5 R0$: E ::= E Op E . [p=R0:2@2-4; c=R1$@4-5] ahm3: R0$@0-5 R0$: E ::= E Op E . [p=R0:2@0-2; c=R0$@2-5] [p=R0:2@0-4; c=R1$@4-5] ahm1: R0:1@0-5 R0:1: E ::= E . Op E [p=R0:0@0-0; c=R0$@0-5] ahm7: R2$@0-5 R2$: E['] ::= E . [p=R2:0@0-0; c=R0$@0-5] ahm1: R0:1@2-5 R0:1: E ::= E . Op E [p=R0:0@2-2; c=R0$@2-5] Earley Set 6 ahm2: R0:2@2-6 R0:2: E ::= E Op . E [c=R0:1@2-5; s=Op; t=\'+'] ahm2: R0:2@0-6 R0:2: E ::= E Op . E [c=R0:1@0-5; s=Op; t=\'+'] ahm2: R0:2@4-6 R0:2: E ::= E Op . E [c=R0:1@4-5; s=Op; t=\'+'] ahm0: R0:0@6-6 R0:0: E ::= . E Op E ahm4: R1:0@6-6 R1:0: E ::= . Number Earley Set 7 ahm5: R1$@6-7 R1$: E ::= Number . [c=R1:0@6-6; s=Number; t=\1] ahm1: R0:1@6-7 R0:1: E ::= E . Op E [p=R0:0@6-6; c=R1$@6-7] ahm3: R0$@4-7 R0$: E ::= E Op E . [p=R0:2@4-6; c=R1$@6-7] ahm3: R0$@0-7 R0$: E ::= E Op E . [p=R0:2@0-2; c=R0$@2-7] [p=R0:2@0-4; c=R0$@4-7] [p=R0:2@0-6; c=R1$@6-7] ahm3: R0$@2-7 R0$: E ::= E Op E . [p=R0:2@2-4; c=R0$@4-7] [p=R0:2@2-6; c=R1$@6-7] ahm1: R0:1@2-7 R0:1: E ::= E . Op E [p=R0:0@2-2; c=R0$@2-7] ahm1: R0:1@0-7 R0:1: E ::= E . Op E [p=R0:0@0-0; c=R0$@0-7] ahm7: R2$@0-7 R2$: E['] ::= E . [p=R2:0@0-0; c=R0$@0-7] ahm1: R0:1@4-7 R0:1: E ::= E . Op E [p=R0:0@4-4; c=R0$@4-7] END_OF_EARLEY_SETS Marpa::R2::Test::is( ${$actual_ref}, $expected_earley_sets, 'Ambiguous Equation Earley Sets' ); restore_stdout(); $actual_ref = save_stdout(); # Marpa::R2::Display # name: show_progress Synopsis print $recce->show_progress() or die "print failed: $ERRNO"; # Marpa::R2::Display::End Marpa::R2::Test::is( ${$actual_ref}, <<'END_OF_PROGRESS_REPORT', 'Ambiguous Equation Progress Report' ); R0:1 x4 @0...6-7 E -> E . Op E F0 x3 @0,2,4-7 E -> E Op E . F1 @6-7 E -> Number . END_OF_PROGRESS_REPORT restore_stdout(); my %expected_value = ( '(2-(0*(3+1)))==2' => 1, '(((2-0)*3)+1)==7' => 1, '((2-(0*3))+1)==3' => 1, '((2-0)*(3+1))==8' => 1, '(2-((0*3)+1))==1' => 1, ); # Set max at 10 just in case there's an infinite loop. # This is for debugging, after all # Marpa::R2::Display # name: Recognizer set Synopsis $recce->set( { max_parses => 10, } ); # Marpa::R2::Display::End my $i = 0; while ( defined( my $value = $recce->value() ) ) { my $value = ${$value}; if ( defined $expected_value{$value} ) { delete $expected_value{$value}; Test::More::pass("Expected Value $i: $value"); } else { Test::More::fail("Unexpected Value $i: $value"); } $i++; } ## end while ( defined( my $value = $recce->value() ) ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_event.t0000444000000000000000000001163612342464706015316 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test of scannerless parsing -- predicted, nulled and completed events with # deactivation and reactivation use 5.010; use strict; use warnings; use Test::More tests => 44; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $rules = <<'END_OF_GRAMMAR'; :start ::= sequence sequence ::= A B C D E F G H I J K L action => OK A ::= 'a' B ::= 'b' C ::= 'c' D ::= 'd' E ::= F ::= 'f' G ::= H ::= 'h' I ::= 'i' J ::= 'j' K ::= L ::= 'l' # Marpa::R2::Display # name: SLIF predicted event statement synopsis event '^a' = predicted A # Marpa::R2::Display::End event '^b' = predicted B event '^c' = predicted C event '^d' = predicted D event '^e' = predicted E event '^f' = predicted F event '^g' = predicted G event '^h' = predicted H event '^i' = predicted I event '^j' = predicted J event '^k' = predicted K event '^l' = predicted L event 'a' = completed A event 'b' = completed B event 'c' = completed C event 'd' = completed D event 'e' = completed E event 'f' = completed F event 'g' = completed G event 'h' = completed H event 'i' = completed I event 'j' = completed J event 'k' = completed K event 'l' = completed L event 'a[]' = nulled A event 'b[]' = nulled B event 'c[]' = nulled C event 'd[]' = nulled D event 'e[]' = nulled E event 'f[]' = nulled F event 'g[]' = nulled G event 'h[]' = nulled H event 'i[]' = nulled I event 'j[]' = nulled J event 'k[]' = nulled K event 'l[]' = nulled L END_OF_GRAMMAR # This test the order of events # No more than one of each event type per line # so that order is non-arbitrary my $all_events_expected = <<'END_OF_EVENTS'; 0 ^a 1 a ^b 2 b ^c 3 c ^d 4 d e[] ^f 5 f g[] ^h 6 h ^i 7 i ^j 8 j k[] ^l 9 l END_OF_EVENTS my %pos_by_event = (); my @events; for my $pos_events (split /\n/xms, $all_events_expected) { my ($pos, @pos_events) = split " ", $pos_events; $pos_by_event{$_} = $pos for @pos_events; push @events, @pos_events; } my $grammar = Marpa::R2::Scanless::G->new( { source => \$rules } ); my $location_0_event = qq{0 ^a\n} ; # Test of all events do_test( "all events", $grammar, q{abcdfhijl}, $all_events_expected ); # Now deactivate all events do_test( "all events deactivated", $grammar, q{abcdfhijl}, $location_0_event, [] ); # Now deactivate all events, and turn them back on, one at a time EVENT: for my $event (@events) { next EVENT if $event eq '^a'; # Location 0 events cannot be deactivated my $expected_events = $location_0_event . $pos_by_event{$event} . " $event\n"; do_test( qq{event "$event" reactivated}, $grammar, q{abcdfhijl}, $expected_events, [$event] ); } sub show_last_subtext { my ($slr) = @_; my ( $start, $end ) = $slr->last_completed_range('subtext'); return 'No expression was successfully parsed' if not defined $start; return $slr->range_to_string( $start, $end ); } sub do_test { my ( $test, $slg, $string, $expected_events, $reactivate_events ) = @_; my $actual_events = q{}; my $slr = Marpa::R2::Scanless::R->new( { grammar => $grammar, semantics_package => 'My_Actions' } ); if (defined $reactivate_events) { # Marpa::R2::Display # name: SLIF activate() method synopsis $slr->activate($_, 0) for @events; # Marpa::R2::Display::End $slr->activate($_) for @{$reactivate_events}; } my $length = length $string; my $pos = $slr->read( \$string ); READ: while (1) { my @actual_events = (); # Marpa::R2::Display # name: SLIF events() method synopsis EVENT: for my $event ( @{ $slr->events() } ) { my ($name) = @{$event}; push @actual_events, $name; } # Marpa::R2::Display::End if (@actual_events) { $actual_events .= join q{ }, $pos, @actual_events; $actual_events .= "\n"; } last READ if $pos >= $length; $pos = $slr->resume($pos); } ## end READ: while (1) my $value_ref = $slr->value(); if ( not defined $value_ref ) { die "No parse\n"; } my $actual_value = ${$value_ref}; Test::More::is( $actual_value, q{1792}, qq{Value for $test} ); Marpa::R2::Test::is( $actual_events, $expected_events, qq{Events for $test} ); } ## end sub do_test sub My_Actions::OK { return 1792 }; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/deprecated1.t0000444000000000000000000000353612342464706015660 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # !!! WARNING !!! # The code in this test uses deprecated methods, techniques, etc. # Please DO NOT USE IT AS AN EXAMPLE # Thanks use 5.010; use strict; use warnings; use Test::More tests => 2; use lib 'inc'; use Marpa::R2::Test; use English qw( -no_match_vars ); use Fatal qw( close open ); use Marpa::R2; # Test the deprecated, zero-argument form # of the thin grammar constructor. my $grammar = Marpa::R2::Thin::G->new(); # Carry on with it a little ways, # just to show that the recognizer starts out # sane my $symbol_S = $grammar->symbol_new(); my $symbol_a = $grammar->symbol_new(); $grammar->start_symbol_set($symbol_S); $grammar->rule_new( $symbol_S, [ $symbol_a, $symbol_a ] ); $grammar->precompute(); my $recce = Marpa::R2::Thin::R->new($grammar); $recce->start_input(); $recce->alternative( $symbol_a, 1, 1 ); $recce->earleme_complete(); my @terminals = $recce->terminals_expected(); Test::More::is( ( scalar @terminals ), 1, 'count of terminals expected' ); Test::More::is( $terminals[0], $symbol_a, 'expected terminal' ); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/rewrite.t0000444000000000000000000000561312342464707015157 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Rewriting tests, to check the accuracy of the # tracing documentation. use 5.010; use strict; use warnings; use Fatal qw(open close); use Test::More tests => 2; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $chaf_rule = { lhs => 'statement', rhs => [ qw/optional_whitespace expression optional_whitespace optional_modifier optional_whitespace/ ] }; my $separated_sequence_rule = { lhs => 'statements', rhs => [qw/statement/], separator => 'comma', min => 1 }; our $null_parse = 'Null parse'; my $sequence_rule = { lhs => 'block', rhs => [qw/statements/], min => 0, action => 'main::null_parse' }; my $grammar = Marpa::R2::Grammar->new( { start => 'block', terminals => [qw(block whitespace modifier expression comma)], rules => [ $chaf_rule, $separated_sequence_rule, $sequence_rule, { lhs => 'optional_whitespace', rhs => [qw(whitespace)] }, { lhs => 'optional_whitespace', }, { lhs => 'optional_modifier', rhs => [qw(modifier)] }, { lhs => 'optional_modifier', }, ], } ); $grammar->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); # While we are at it, test the handling of null parses in # the Single Parse Evaluator $recce->end_input(); # Marpa::R2::Display::End my $show_rules_output = $grammar->show_rules(); Marpa::R2::Test::is( $show_rules_output, <<'END_RULES', 'Rewritten Rules' ); 0: statement -> optional_whitespace expression optional_whitespace optional_modifier optional_whitespace 1: statements -> statement+ /* discard_sep */ 2: block -> statements* 3: optional_whitespace -> whitespace 4: optional_whitespace -> /* empty !used */ 5: optional_modifier -> modifier 6: optional_modifier -> /* empty !used */ END_RULES my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No Parse'; Marpa::R2::Test::is( $value, 'Null parse', 'Null parse value' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_wall.t0000444000000000000000000000731512342464707015134 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # use 5.010; use strict; use warnings; # The Wall Series: a sequence of numbers generated by an especially # ambiguous section of Perl syntax, relaxed to ignore precedence # and lvalue restricitons. # This produces numbers in the series A052952 in the literature. # It's a kind of ragtime Fibonacci series. My proof that the # parse counts generated by this grammar and A052952 are identical # is at perlmonks.org: http://perlmonks.org/?node_id=649892 use Test::More tests => 12; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; # The inefficiency (at least some of it) is deliberate. # Passing up a duples of [ string, value ] and then # assembling a final string at the top would be better # than assembling the string then taking it # apart at each step. But I wanted to test having # a start symbol that appears repeatedly on the RHS. ## no critic (Subroutines::RequireArgUnpacking) sub My_Actions::minus { shift; my ( $right_string, $right_value ) = ( $_[2] =~ /^(.*)==(.*)$/xms ); my ( $left_string, $left_value ) = ( $_[0] =~ /^(.*)==(.*)$/xms ); my $value = $left_value - $right_value; return '(' . $left_string . q{-} . $right_string . ')==' . $value; } ## end sub minus sub My_Actions::postfix_decr { shift; my ( $string, $value ) = ( $_[0] =~ /^(.*)==(.*)$/xms ); return '(' . $string . q{--} . ')==' . $value--; } sub My_Actions::prefix_decr { shift; my ( $string, $value ) = ( $_[2] =~ /^(.*)==(.*)$/xms ); return '(' . q{--} . $string . ')==' . --$value; } sub My_Actions::negation { shift; my ( $string, $value ) = ( $_[1] =~ /^(.*)==(.*)$/xms ); return '(' . q{-} . $string . ')==' . -$value; } sub My_Actions::number { shift; return "$_[0]==$_[0]"; } sub My_Actions::default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . join( q{;}, @_ ) . ')'; } ## end sub default_action ## use critic my $g = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :start ::= E :default ::= action => default_action E ::= E Minus E action => minus | E Minus Minus action => postfix_decr | Minus Minus E action => prefix_decr | Minus E action => negation | Number action => number Number ~ [0-9] Minus ~ '-' END_OF_SOURCE } ); my @expected = qw(0 1 1 3 4 8 12 21 33 55 88 144 232 ); for my $n ( 1 .. 12 ) { # Set max_parses just in case there's an infinite loop. # This is for debugging, after all my $recce = Marpa::R2::Scanless::R->new( { grammar => $g, semantics_package => 'My_Actions', max_parses => 300 } ); $recce->read( \'6-', 0, 1 ); $recce->resume( 1, 1 ) for 1 .. $n; $recce->resume( 0, 1 ); my $parse_count = 0; while ( $recce->value() ) { $parse_count++; } Marpa::R2::Test::is( $expected[$n], $parse_count, "Wall Series Number $n" ); } ## end for my $n ( 1 .. 12 ) 1; # In case used as "do" file # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_panda1.t0000555000000000000000000002037112342464706015340 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # This example parses ambiguous English sentences. The target annotation # is Penn Treebank's syntactic bracketing tags. For details, see # http://www.cis.upenn.edu/~treebank/ use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Test::More tests => 3; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $dsl = <<'END_OF_SOURCE'; S ::= NP VP period action => do_S NP ::= NN action => do_NP_NN | NNS action => do_NP_NNS | DT NN action => do_NP_DT_NN | NN NNS action => do_NP_NN_NNS | NNS CC NNS action => do_NP_NNS_CC_NNS VP ::= VBZ NP action => do_VP_VBZ_NP | VP VBZ NNS action => do_VP_VP_VBZ_NNS | VP CC VP action => do_VP_VP_CC_VP | VP VP CC VP action => do_VP_VP_VP_CC_VP | VBZ action => do_VP_VBZ period ~ '.' :discard ~ whitespace whitespace ~ [\s]+ CC ~ 'and' DT ~ 'a' | 'an' NN ~ 'panda' NNS ~ 'shoots' | 'leaves' VBZ ~ 'eats' | 'shoots' | 'leaves' END_OF_SOURCE my $grammar = Marpa::R2::Scanless::G->new( { source => \$dsl } ); my $full_expected = <<'END_OF_OUTPUT'; (S (NP (DT a) (NN panda)) (VP (VBZ eats) (NP (NNS shoots) (CC and) (NNS leaves))) (. .)) (S (NP (DT a) (NN panda)) (VP (VP (VBZ eats) (NP (NNS shoots))) (CC and) (VP (VBZ leaves))) (. .)) (S (NP (DT a) (NN panda)) (VP (VP (VBZ eats)) (VP (VBZ shoots)) (CC and) (VP (VBZ leaves))) (. .)) END_OF_OUTPUT my $sentence = 'a panda eats shoots and leaves.'; my @actual = (); my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar, semantics_package => 'PennTags' } ); $recce->read( \$sentence ); while ( defined( my $value_ref = $recce->value() ) ) { my $value = $value_ref ? ${$value_ref} : 'No parse'; push @actual, $value; } Marpa::R2::Test::is( ( join "\n", sort @actual ) . "\n", $full_expected, 'Ambiguous English sentence using value()' ); my $panda_grammar = Marpa::R2::Scanless::G->new( { source => \$dsl } ); my $panda_recce = Marpa::R2::Scanless::R->new( { grammar => $panda_grammar, semantics_package => 'PennTags' } ); $panda_recce->read( \$sentence ); my $asf = Marpa::R2::ASF->new( { slr=>$panda_recce } ); my $full_result = $asf->traverse( {}, \&full_traverser ); my $pruned_result = $asf->traverse( {}, \&pruning_traverser ); sub full_traverser { # This routine converts the glade into a list of Penn-tagged elements # by calling semantic action closures fetched from the recognizer. # It is called recursively. my ($glade, $scratch) = @_; my $rule_id = $glade->rule_id(); my $symbol_id = $glade->symbol_id(); my $symbol_name = $panda_grammar->symbol_name($symbol_id); # A token is a single choice and we just return it as a literal wrapped # to match the rule closures parameter list if ( not defined $rule_id ) { return [ $glade->literal() ]; } ## end if ( not defined $rule_id ) # Our result will be a list of choices my @return_value = (); CHOICE: while (1) { # The parse results at each position are a list of choices, so # to produce a new result list, we need to take a Cartesian # product of all the choices my @values = $glade->rh_values(); my @results = ( [] ); for my $rh_ix ( 0 .. @values - 1 ) { my @new_results = (); for my $old_result (@results) { my $child_value = $values[$rh_ix]; for my $new_value ( @{ $child_value } ) { push @new_results, [ @{$old_result}, $new_value ]; } } @results = @new_results; } ## end for my $rh_ix ( 0 .. $length - 1 ) # Special case for the start rule: just collapse one level of lists if ( $symbol_name eq '[:start]' ) { return [ map { join q{}, @{$_} } @results ]; } # Now we have a list of choices, as a list of lists. Each sub list # is a list of parse results, which we need to pass to the rule closures # and join into a single Penn-tagged element. The result will be # to collapse one level of lists, and leave us with a list of # Penn-tagged elements. # First, we take the semantic action closure of the rule as defined in the # recognizer's semantic package. my $closure = $panda_recce->rule_closure( $glade->rule_id() ); # Note: $glade->rule_id() is used instead of the above $rule_id, because # $glade->next() must have been called and the current glade (and thus # the rule) might have changed # Now, we need to check if the semantic action of the rule is defined # as a closure. For now, we just die if it is not. # # However, start, length, lhs, and values builtins can be emulated by # using $glade->span(), $glade->symbol_id(), and $glade->rh_values(). # Stull, defining closures would probably serve you better. unless (defined $closure and ref $closure eq 'CODE'){ die "The semantics of Rule #" . $glade->rule_id() . "is not defined as a closure."; } push @return_value, map { $closure->( {}, @{$_} ) } @results; # Look at the next alternative in this glade, or end the # loop if there is none last CHOICE if not defined $glade->next(); } ## end CHOICE: while (1) # Return the list of Penn-tagged elements for this glade return \@return_value; } ## end sub full_traverser my $cooked_result = join "\n", (sort @{$full_result}), q{}; Marpa::R2::Test::is( $cooked_result, $full_expected, 'Ambiguous English sentence using ASF' ); sub pruning_traverser { # This routine converts the glade into a list of Penn-tagged elements. It is called recursively. my ($glade, $scratch) = @_; my $rule_id = $glade->rule_id(); my $symbol_id = $glade->symbol_id(); my $symbol_name = $panda_grammar->symbol_name($symbol_id); # A token is a single choice, and we know enough to fully Penn-tag it if ( not defined $rule_id ) { return $glade->literal(); # wrap for the closure call } my @return_value = $glade->rh_values(); if ($symbol_name eq '[:start]'){ # Special case for the start rule return $return_value[0] . "\n" ; } else{ my $closure = $panda_recce->rule_closure($rule_id); die "The semantics of Rule $rule_id is not defined as a closure." unless defined $closure and ref $closure eq 'CODE'; return $closure->( {}, @return_value ); } } my $pruned_expected = <<'END_OF_OUTPUT'; (S (NP (DT a) (NN panda)) (VP (VBZ eats) (NP (NNS shoots) (CC and) (NNS leaves))) (. .)) END_OF_OUTPUT Marpa::R2::Test::is( $pruned_result, $pruned_expected, 'Ambiguous English sentence using ASF: pruned' ); sub PennTags::do_S { "(S $_[1]\n $_[2]\n (. .))" } sub PennTags::do_NP_NN { "(NP (NN $_[1]))" } sub PennTags::do_NP_NNS { "(NP (NNS $_[1]))" } sub PennTags::do_NP_DT_NN { "(NP (DT $_[1]) (NN $_[2]))" } sub PennTags::do_NP_NN_NNS { "(NP (NN $_[1]) (NNS $_[2]))" } sub PennTags::do_NP_NNS_CC_NNS { "(NP (NNS $_[1]) (CC $_[2]) (NNS $_[3]))" } sub PennTags::do_VP_VBZ_NP { "(VP (VBZ $_[1]) $_[2])" } sub PennTags::do_VP_VP_VBZ_NNS { "(VP $_[1] (VBZ $_[2]) (NNS $_[3]))" } sub PennTags::do_VP_VP_CC_VP { "(VP $_[1] (CC $_[2]) $_[3])" } sub PennTags::do_VP_VP_VP_CC_VP { "(VP $_[1] $_[2] (CC $_[3]) $_[4])" } sub PennTags::do_VP_VBZ { "(VP (VBZ $_[1]))" } 1; # In case used as "do" file Marpa-R2-2.086000~dfsg/t/00-load.t0000444000000000000000000000422012342464706014622 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use warnings; use strict; use English qw( -no_match_vars ); use Test::More tests => 4; my $ok = eval { require Marpa::R2; 1; }; Test::More::BAIL_OUT('Could not load Marpa::R2') if not $ok; my $marpa_version_ok = defined $Marpa::R2::VERSION; my $marpa_version_desc = $marpa_version_ok ? 'Marpa::R2 version is ' . $Marpa::R2::VERSION : 'No Marpa::R2::VERSION'; Test::More::ok( $marpa_version_ok, $marpa_version_desc ); my $marpa_string_version_ok = defined $Marpa::R2::STRING_VERSION; my $marpa_string_version_desc = "Marpa::R2 version is " . $Marpa::R2::STRING_VERSION // 'No Marpa::R2::STRING_VERSION'; Test::More::ok( $marpa_string_version_ok, $marpa_string_version_desc ); my @libmarpa_version = Marpa::R2::Thin::version(); my $libmarpa_version_ok = scalar @libmarpa_version; my $libmarpa_version_desc = $libmarpa_version_ok ? ( "Libmarpa version is " . join q{.}, @libmarpa_version ) : "No Libmarpa version"; Test::More::ok( $libmarpa_version_ok, $libmarpa_version_desc ); Test::More::diag($marpa_string_version_desc); Test::More::diag($libmarpa_version_desc); Test::More::diag('Libmarpa tag: ' . Marpa::R2::Thin::tag()); my $grammar; my $eval_ok = eval { $grammar = Marpa::R2::Thin::G->new( { if => 1 } ); 1 }; Test::More::diag($EVAL_ERROR) if not $eval_ok; Test::More::ok( ($eval_ok && $grammar), 'Thin grammar created' ) or Test::More::BAIL_OUT('Could not create Marpa grammar'); # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_durand.t0000444000000000000000000000536512342464707015455 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Regression tests for several bugs found by Jean-Damien use 5.010; use strict; use warnings; use Test::More tests => 10; use lib 'inc'; use Marpa::R2::Test; ## no critic (ErrorHandling::RequireCarping); use Marpa::R2; my $dsl; my $grammar; my $recce; my $input; my $length; my $expected_output; my $actual_output; my $pos = 0; # This first problem was with ambiguous SLIF parses when # used together with values from an external scanner $dsl = <<'END_OF_SOURCE'; :default ::= action => ::first :start ::= Expression Expression ::= Number | Expression Add Expression action => do_add | Expression Multiply Expression action => do_multiply Add ~ '+' Multiply ~ '*' Number ~ digits digits ~ [\d]+ :discard ~ whitespace whitespace ~ [\s]+ END_OF_SOURCE $grammar = Marpa::R2::Scanless::G->new( { source => \$dsl } ); $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar, semantics_package => 'My_Actions' } ); $input = '2*1+3*4+5'; $pos = 0; $recce->read( \$input, 0, 0 ); for my $input_token (qw(2 * 1 + 3 * 4 + 5)) { my $token_type = $input_token eq '+' ? 'Add' : $input_token eq '*' ? 'Multiply' : 'Number'; my $return_value = $recce->lexeme_read( $token_type, $pos, 1, $input_token ); $pos++; Test::More::is( $return_value, $pos, "Return value of lexeme_read() is $pos" ); } ## end for my $input_token (qw(2 * 1 + 3 * 4 + 5)) my @values = (); while ( my $value_ref = $recce->value() ) { push @values, ${$value_ref}; } $expected_output = '19 19 25 29 31 36 36 37 37 42 45 56 72 72'; $actual_output = join " ", sort @values; Test::More::is( $actual_output, $expected_output, 'Values for Durand test' ); sub My_Actions::do_add { my ( undef, $t1, undef, $t2 ) = @_; return $t1 + $t2; } sub My_Actions::do_multiply { my ( undef, $t1, undef, $t2 ) = @_; return $t1 * $t2; } 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/catalan.t0000444000000000000000000000432612342464706015100 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; # Count the ways of parenthesizing N symbols in pairs # This generates the Catalan numbers use strict; use warnings; use Test::More tests => 7; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $g = Marpa::R2::Grammar->new( { start => 'pair', rules => [ [ pair => [qw(a a)], '::whatever' ], [ pair => [qw(pair a)], '::whatever' ], [ pair => [qw(a pair)], '::whatever' ], [ pair => [qw(pair pair)], '::whatever' ], ], terminals => ['a'], } ); $g->precompute(); sub do_pairings { my $n = shift; my $parse_count = 0; my $recce = Marpa::R2::Recognizer->new( { grammar => $g } ); # An arbitrary maximum is put on the number of parses -- this is for # debugging, and infinite loops happen. $recce->set( { max_parses => 999, } ); for my $token_ix ( 0 .. $n - 1 ) { $recce->read('a'); } while ( my $value_ref = $recce->value() ) { $parse_count++; } return $parse_count; } ## end sub do_pairings my @catalan_numbers = ( 0, 1, 1, 2, 5, 14, 42, 132, 429 ); for my $a ( ( 2 .. 8 ) ) { my $actual_parse_count = do_pairings($a); Marpa::R2::Test::is( $actual_parse_count, $catalan_numbers[$a], "Catalan number $a matches parse count ($actual_parse_count)" ); } ## end for my $a ( ( 2 .. 8 ) ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_exhaust.t0000444000000000000000000001240512342464707015652 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Tests of scannerless parsing -- some corner cases, # including exhaustion at G1 level use 5.010; use strict; use warnings; use Test::More tests => 72; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $source_template = <<'END_OF_SOURCE'; :default ::= action => do_list :start ::= Number Number ::= number # If I add '+' or '*' it will work... %QUANTIFIER% number ~ [\d]+ :discard ~ whitespace whitespace ~ [\s]+ END_OF_SOURCE (my $source_bare = $source_template) =~ s/ %QUANTIFIER% / /xms; (my $source_plus = $source_template) =~ s/ %QUANTIFIER% / + /xms; (my $source_star = $source_template) =~ s/ %QUANTIFIER% / * /xms; my $grammar_bare = Marpa::R2::Scanless::G->new( { source => \$source_bare } ); my $grammar_plus = Marpa::R2::Scanless::G->new( { source => \$source_plus } ); my $grammar_star = Marpa::R2::Scanless::G->new( { source => \$source_star } ); package My_Actions; sub do_list { shift; return join " ", @_; } sub show_last_expression { my ($self) = @_; my $slr = $self->{slr}; my ( $start, $end ) = $slr->last_completed_range('Number'); return '[none]' if not defined $start; my $last_expression = $slr->range_to_string( $start, $end ); return $last_expression; } ## end sub show_last_expression package main; sub my_parser { my ( $grammar, $string ) = @_; my $self = bless { grammar => $grammar }, 'My_Actions'; my $slr = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); $self->{slr} = $slr; my ( $parse_value, $parse_status, $last_expression ); my $eval_ok = eval { $slr->read( \$string ); 1; }; my $eval_error = $EVAL_ERROR; # Marpa::R2::Display # name: $slr->exhausted example my $exhausted_status = $slr->exhausted(); # Marpa::R2::Display::End if ( not $eval_ok ) { chomp $eval_error; $eval_error =~ s/\n.*//xms; return 'No parse', $eval_error, $self->show_last_expression(), $exhausted_status; } ## end if ( not $eval_ok ) my $value_ref = $slr->value($self); if ( not defined $value_ref ) { return 'No parse', 'Input read to end but no parse', $self->show_last_expression(), $exhausted_status; } my $value = ${$value_ref} // ''; return $value, 'Parse OK', 'entire input', $exhausted_status; } ## end sub my_parser my %grammar_by_type = ( 'Bare' => $grammar_bare, 'Plus' => $grammar_plus, 'Star' => $grammar_star, ); my @tests_data = ( [ 'Bare', '', 'No parse', 'Input read to end but no parse', '[none]' ], [ 'Bare', '1', '1', 'Parse OK', 'entire input', 1 ], [ 'Bare', '1 2', 'No parse', 'Error in SLIF parse: Parse exhausted, but lexemes remain, at line 1, column 3', '1', 1 ], [ 'Plus', '', 'No parse', 'Input read to end but no parse', '[none]' ], [ 'Plus', '1', '1', 'Parse OK', 'entire input' ], [ 'Plus', '1 2', '1 2', 'Parse OK', 'entire input' ], [ 'Star', '', '', 'Parse OK', 'entire input' ], [ 'Star', '1', '1', 'Parse OK', 'entire input' ], [ 'Star', '1 2', '1 2', 'Parse OK', 'entire input' ], ); for my $trailer ( q{}, q{ } ) { for my $test_data (@tests_data) { my ( $type, $test_string, $expected_value, $expected_result, $expected_last_expression, $expected_exhaustion_status ) = @{$test_data}; $test_string .= $trailer; my ( $actual_value, $actual_result, $actual_last_expression, $actual_exhaustion_status ) = my_parser( $grammar_by_type{$type}, $test_string ); Test::More::is( $actual_value, $expected_value, qq{$type: Value of "$test_string"} ); Test::More::is( $actual_result, $expected_result, qq{$type: Result of "$test_string"} ); Test::More::is( $actual_last_expression, $expected_last_expression, qq{$type: Last expression found in "$test_string"} ); if ($actual_exhaustion_status) { if (not $expected_exhaustion_status) { Test::More::fail(qq{$type: exhausted for "$test_string", but should not be}); } else { Test::More::pass(qq{$type: exhausted for "$test_string"}); } } else { if ($expected_exhaustion_status) { Test::More::fail(qq{$type: not exhausted for "$test_string", but should be}); } else { Test::More::pass(qq{$type: not exhausted for "$test_string"}); } } } ## end for my $test_data (@tests_data) } ## end for my $trailer ( q{}, q{ } ) # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_rank.t0000444000000000000000000000413412342464706015123 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Tests negative ranks, SLIF ranks and # external SLIF scanning # This uses an ambiguous grammar to implement a binary # counter. A very expensive way to do it, but a # good test of the ranking logic. use 5.010; use strict; use warnings; use Test::More tests => 16; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; sub My_Actions::zero { return '0' } sub My_Actions::one { return '1' } sub My_Actions::start_rule_action { shift; return join q{}, @_; } ## use critic my $grammar = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_GRAMMAR'), :start ::= S S ::= digit digit digit digit action => start_rule_action digit ::= zero rank => 1 action => zero | one rank => -1 action => one zero ~ 't' one ~ 't' END_OF_GRAMMAR } ); my @counting_up = qw{ 0000 0001 0010 0011 0100 0101 0110 0111 1000 1001 1010 1011 1100 1101 1110 1111 }; my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar, semantics_package => 'My_Actions', ranking_method => 'rule' } ); $recce->read(\'tttt'); my $i = 0; while ( my $result = $recce->value() ) { my $got = ${$result}; my $expected = reverse $counting_up[$i]; Test::More::is( $got, $expected, "counting up $i" ); $i++; } ## end while ( my $result = $recce->value() ) 1; # In case used as "do" file # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/asf_syn.t0000444000000000000000000001430612342464706015136 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # The low-level ASF synopses and related tests use 5.010; use strict; use warnings; use Test::More tests => 1; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; use Data::Dumper; use Scalar::Util; # Marpa::R2::Display # name: ASF low-level calls synopsis, code part 1 my $grammar = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :start ::= pair pair ::= duple | item item duple ::= item item item ::= Hesperus | Phosphorus Hesperus ::= 'a' Phosphorus ::= 'a' END_OF_SOURCE } ); my $slr = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); $slr->read( \'aa' ); my $asf = Marpa::R2::ASF->new( { slr => $slr } ); die 'No ASF' if not defined $asf; my $output_as_array = asf_to_basic_tree($asf); my $actual_output = array_display($output_as_array); # Marpa::R2::Display::End # Marpa::R2::Display # name: ASF low-level calls synopsis, output # start-after-line: EXPECTED_OUTPUT # end-before-line: '^EXPECTED_OUTPUT$' my $expected_output = <<'EXPECTED_OUTPUT'; Glade 2 has 2 symches Glade 2, Symch 0, pair ::= duple Glade 6, duple ::= item item Glade 8 has 2 symches Glade 8, Symch 0, item ::= Hesperus Glade 13, Hesperus ::= 'a' Glade 15, Symbol 'a': "a" Glade 8, Symch 1, item ::= Phosphorus Glade 1, Phosphorus ::= 'a' Glade 17, Symbol 'a': "a" Glade 7 has 2 symches Glade 7, Symch 0, item ::= Hesperus Glade 22, Hesperus ::= 'a' Glade 24, Symbol 'a': "a" Glade 7, Symch 1, item ::= Phosphorus Glade 9, Phosphorus ::= 'a' Glade 26, Symbol 'a': "a" Glade 2, Symch 1, pair ::= item item Glade 8 revisited Glade 7 revisited EXPECTED_OUTPUT # Marpa::R2::Display::End Marpa::R2::Test::is( $actual_output, $expected_output, 'Output for basic ASF synopsis' ); # Marpa::R2::Display # name: ASF low-level calls synopsis, code part 2 sub asf_to_basic_tree { my ( $asf, $glade ) = @_; my $peak = $asf->peak(); return glade_to_basic_tree( $asf, $peak, [] ); } ## end sub asf_to_basic_tree sub glade_to_basic_tree { my ( $asf, $glade, $seen ) = @_; return bless ["Glade $glade revisited"], 'My_Revisit' if $seen->[$glade]; $seen->[$glade] = 1; my $grammar = $asf->grammar(); my @symches = (); my $symch_count = $asf->glade_symch_count($glade); SYMCH: for ( my $symch_ix = 0; $symch_ix < $symch_count; $symch_ix++ ) { my $rule_id = $asf->symch_rule_id( $glade, $symch_ix ); if ( $rule_id < 0 ) { my $literal = $asf->glade_literal($glade); my $symbol_id = $asf->glade_symbol_id($glade); my $display_form = $grammar->symbol_display_form($symbol_id); push @symches, bless [qq{Glade $glade, Symbol $display_form: "$literal"}], 'My_Token'; next SYMCH; } ## end if ( $rule_id < 0 ) # ignore any truncation of the factorings my $factoring_count = $asf->symch_factoring_count( $glade, $symch_ix ); my @symch_description = ("Glade $glade"); push @symch_description, "Symch $symch_ix" if $symch_count > 1; push @symch_description, $grammar->rule_show($rule_id); my $symch_description = join q{, }, @symch_description; my @factorings = ($symch_description); for ( my $factoring_ix = 0; $factoring_ix < $factoring_count; $factoring_ix++ ) { my $downglades = $asf->factoring_downglades( $glade, $symch_ix, $factoring_ix ); push @factorings, bless [ map { glade_to_basic_tree( $asf, $_, $seen ) } @{$downglades} ], 'My_Rule'; } ## end for ( my $factoring_ix = 0; $factoring_ix < $factoring_count...) if ( $factoring_count > 1 ) { push @symches, bless [ "Glade $glade, symch $symch_ix has $factoring_count factorings", @factorings ], 'My_Factorings'; next SYMCH; } ## end if ( $factoring_count > 1 ) push @symches, bless [ @factorings[ 0, 1 ] ], 'My_Factorings'; } ## end SYMCH: for ( my $symch_ix = 0; $symch_ix < $symch_count; ...) return bless [ "Glade $glade has $symch_count symches", @symches ], 'My_Symches' if $symch_count > 1; return $symches[0]; } ## end sub glade_to_basic_tree # Marpa::R2::Display::End # Marpa::R2::Display # name: ASF low-level calls synopsis, code part 3 sub array_display { my ($array) = @_; my ( undef, @lines ) = @{ array_lines_display($array) }; my $text = q{}; for my $line (@lines) { my ( $indent, $body ) = @{$line}; $indent -= 6; $text .= ( q{ } x $indent ) . $body . "\n"; } return $text; } ## end sub array_display sub array_lines_display { my ($array) = @_; my $reftype = Scalar::Util::reftype($array) // '!undef!'; return [ [ 0, $array ] ] if $reftype ne 'ARRAY'; my @lines = (); ELEMENT: for my $element ( @{$array} ) { for my $line ( @{ array_lines_display($element) } ) { my ( $indent, $body ) = @{$line}; push @lines, [ $indent + 2, $body ]; } } ## end ELEMENT: for my $element ( @{$array} ) return \@lines; } ## end sub array_lines_display # Marpa::R2::Display::End # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_taint.t0000444000000000000000000000321112342464707015303 0ustar rootroot#!perl -T # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test of scannerless parsing for tainted grammars use 5.010; use strict; use warnings; use Test::More tests => 1; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; # $^X is always tainted my $tainted_grammar = q{:start ::= A A ~ 'a' # } . $^X; # Make sure we fail with tainted data # -T flag was set on first line for this script my $eval_ok = eval { Marpa::R2::Scanless::G->new( { source => \$tainted_grammar } ); 1; }; if ($eval_ok) { Test::More::fail("Tainted grammar accepted -- that should not happen"); } else { my $eval_error = $EVAL_ERROR; Test::More::like( $eval_error, qr/Attempt \s+ to \s+ use \s+ a \s+ tainted \s+ input \s+ string \s+ with \s+ Marpa::R2 \s+ Marpa::R2 \s+ is \s+ insecure \s+ for \s+ use \s+ with \s+ tainted \s+ data/xms, "Tainted grammar detected and rejected" ); } ## end else [ if ($eval_ok) ] # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_leo.t0000444000000000000000000000447112342464707014754 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # The example from p. 166 of Leo's paper, # augmented to test Leo prediction items. # use 5.010; use strict; use warnings; use Test::More tests => 2; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub main::default_action { shift; return ( join q{}, grep {defined} @_ ); } ## use critic my $grammar = Marpa::R2::Scanless::G->new( { default_action => 'main::default_action', source => \(<<'END_OF_DSL'), :start ::= S S ::= 'a' A A ::= B B ::= C C ::= S S ::= event A = completed event C = completed event S = completed # Marpa::R2::Display # name: SLIF nulled event statement synopsis event 'A[]' = nulled # Marpa::R2::Display::End event 'C[]' = nulled event 'S[]' = nulled END_OF_DSL } ); my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); my $input = 'aaa'; my $event_history = q{}; my $pos = $recce->read( \$input ); READ: while (1) { my @event_names; for ( my $ix = 0; my $event = $recce->event($ix); $ix++ ) { push @event_names, @{$event}; } $event_history .= join q{ }, $pos, sort @event_names; $event_history .= "\n"; last READ if $pos >= length $input; $pos = $recce->resume(); } ## end READ: while (1) my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; Marpa::R2::Test::is( $value, 'aaa', 'Leo SLIF parse' ); Marpa::R2::Test::is( $event_history, <<'END_OF_TEXT', 'Event history' ); 1 A[] C[] S S[] 2 A A[] C C[] S S[] 3 A A[] C C[] S S[] END_OF_TEXT # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/minus.t0000444000000000000000000001270212342464707014626 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use Test::More tests => 10; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; # The inefficiency (at least some of it) is deliberate. # Passing up a duples of [ string, value ] and then # assembling a final string at the top would be better # than assembling the string then taking it # apart at each step. But I wanted to test having # a start symbol that appears repeatedly on the RHS. ## no critic (Subroutines::RequireArgUnpacking) sub subtraction { shift; my ( $right_string, $right_value ) = ( $_[2] =~ /^(.*)==(.*)$/xms ); my ( $left_string, $left_value ) = ( $_[0] =~ /^(.*)==(.*)$/xms ); my $value = $left_value - $right_value; return '(' . $left_string . q{-} . $right_string . ')==' . $value; } ## end sub subtraction sub postfix_decr { shift; my ( $string, $value ) = ( $_[0] =~ /^(.*)==(.*)$/xms ); return '(' . $string . q{--} . ')==' . $value--; } sub prefix_decr { shift; my ( $string, $value ) = ( $_[1] =~ /^(.*)==(.*)$/xms ); return '(' . q{--} . $string . ')==' . --$value; } sub negation { shift; my ( $string, $value ) = ( $_[1] =~ /^(.*)==(.*)$/xms ); return '(' . q{-} . $string . ')==' . -$value; } sub number { shift; my $value = $_[0]; return "$value==$value"; } sub default_action { shift; return q{} if scalar @_ <= 0; return $_[0] if scalar @_ == 1; return '(' . join( q{;}, @_ ) . ')'; } ## end sub default_action ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'E', actions => 'main', rules => [ { lhs => 'E', rhs => [qw/E Minus E/], action => 'subtraction', }, { lhs => 'E', rhs => [qw/E MinusMinus/], action => 'postfix_decr', }, { lhs => 'E', rhs => [qw/MinusMinus E/], action => 'prefix_decr', }, { lhs => 'E', rhs => [qw/Minus E/], action => 'negation' }, { lhs => 'E', rhs => [qw/Number/], action => 'number' }, ], # Marpa::R2::Display # name: Symbol descriptor example symbols => { MinusMinus => { terminal => 1 }, Minus => { terminal => 1 }, Number => { terminal => 1 }, }, # Marpa::R2::Display::End default_action => 'default_action', }, ); $grammar->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); Marpa::R2::Test::is( $grammar->show_rules, <<'END_RULES', 'Minuses Equation Rules' ); 0: E -> E Minus E 1: E -> E MinusMinus 2: E -> MinusMinus E 3: E -> Minus E 4: E -> Number END_RULES Marpa::R2::Test::is( $grammar->show_ahms, <<'END_AHMS', 'Minuses Equation AHMs' ); AHM 0: postdot = "E" E ::= . E Minus E AHM 1: postdot = "Minus" E ::= E . Minus E AHM 2: postdot = "E" E ::= E Minus . E AHM 3: completion E ::= E Minus E . AHM 4: postdot = "E" E ::= . E MinusMinus AHM 5: postdot = "MinusMinus" E ::= E . MinusMinus AHM 6: completion E ::= E MinusMinus . AHM 7: postdot = "MinusMinus" E ::= . MinusMinus E AHM 8: postdot = "E" E ::= MinusMinus . E AHM 9: completion E ::= MinusMinus E . AHM 10: postdot = "Minus" E ::= . Minus E AHM 11: postdot = "E" E ::= Minus . E AHM 12: completion E ::= Minus E . AHM 13: postdot = "Number" E ::= . Number AHM 14: completion E ::= Number . AHM 15: postdot = "E" E['] ::= . E AHM 16: completion E['] ::= E . END_AHMS my %expected = map { ( $_ => 1 ) } ( #<<< no perltidy '(((6--)--)-1)==5', '((6--)-(--1))==6', '((6--)-(-(-1)))==5', '(6-(--(--1)))==7', '(6-(--(-(-1))))==6', '(6-(-(--(-1))))==4', '(6-(-(-(--1))))==6', '(6-(-(-(-(-1)))))==5', #>>> ); $recce->read( 'Number', '6' ); for ( 1 .. 4 ) { $recce->alternative( 'MinusMinus', \q{--}, 2 ); $recce->alternative( 'Minus', \q{-} ); $recce->earleme_complete(); } $recce->read( 'Minus', q{-}, ); $recce->read( 'Number', '1' ); # Set max_parses to 20 in case there's an infinite loop. # This is for debugging, after all $recce->set( { max_parses => 20 } ); while ( my $value_ref = $recce->value() ) { my $value = $value_ref ? ${$value_ref} : 'No parse'; if ( defined $expected{$value} ) { delete $expected{$value}; Test::More::pass("Expected Value $value"); } else { Test::More::fail("Unexpected Value $value"); } } ## end while ( my $value_ref = $recce->value() ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/leo3.t0000444000000000000000000000671412342464706014342 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # The example from p. 166 of Leo's paper, # augmented to test Leo prediction items. # use 5.010; use strict; use warnings; use Test::More tests => 7; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub main::default_action { shift; return ( join q{}, grep {defined} @_ ); } ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/a A/] ], [ 'A', [qw/B/] ], [ 'B', [qw/C/] ], [ 'C', [qw/S/] ], [ 'S', [], ], ], terminals => [qw(a)], default_action => 'main::default_action', } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_symbols(), <<'END_OF_STRING', 'Leo166 Symbols' ); 0: a, terminal 1: S 2: A 3: B 4: C END_OF_STRING Marpa::R2::Test::is( $grammar->show_rules, <<'END_OF_STRING', 'Leo166 Rules' ); 0: S -> a A 1: A -> B 2: B -> C 3: C -> S 4: S -> /* empty !used */ END_OF_STRING Marpa::R2::Test::is( $grammar->show_ahms, <<'END_OF_STRING', 'Leo166 AHMs' ); AHM 0: postdot = "a" S ::= . a A AHM 1: postdot = "A" S ::= a . A AHM 2: completion S ::= a A . AHM 3: postdot = "a" S ::= . a A[] AHM 4: completion S ::= a A[] . AHM 5: postdot = "B" A ::= . B AHM 6: completion A ::= B . AHM 7: postdot = "C" B ::= . C AHM 8: completion B ::= C . AHM 9: postdot = "S" C ::= . S AHM 10: completion C ::= S . AHM 11: postdot = "S" S['] ::= . S AHM 12: completion S['] ::= S . END_OF_STRING my $length = 20; LEO_FLAG: for my $leo_flag ( 0, 1 ) { my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, leo => $leo_flag } ); my $i = 0; my $latest_earley_set = $recce->latest_earley_set(); my $max_size = $recce->earley_set_size($latest_earley_set); TOKEN: while ( $i++ < $length ) { $recce->read( 'a', 'a' ); $latest_earley_set = $recce->latest_earley_set(); my $size = $recce->earley_set_size($latest_earley_set); $max_size = $size > $max_size ? $size : $max_size; } ## end while ( $i++ < $length ) # Note that the length formula only works # beginning with Earley set c, for some small # constant c my $expected_size = $leo_flag ? 9 : ( $length - 1 ) * 4 + 8; Marpa::R2::Test::is( $max_size, $expected_size, "Leo flag $leo_flag, size $max_size" ); my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; Marpa::R2::Test::is( $value, 'a' x $length, 'Leo p166 parse' ); } ## end for my $leo_flag ( 0, 1 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/null_example.t0000444000000000000000000000575112342464707016166 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # An ambiguous equation use 5.010; use strict; use warnings; use Test::More tests => 1; use lib 'inc'; use Marpa::R2::Test; use English qw( -no_match_vars ); use Fatal qw(open close); use Marpa::R2; ## no critic (InputOutput::RequireBriefOpen) open my $original_stdout, q{>&STDOUT}; ## use critic sub save_stdout { my $save; my $save_ref = \$save; close STDOUT; open STDOUT, q{>}, $save_ref; return $save_ref; } ## end sub save_stdout sub restore_stdout { close STDOUT; open STDOUT, q{>&}, $original_stdout; return 1; } # Marpa::R2::Display # name: Null Value Example sub do_L { shift; return 'L(' . ( join q{;}, map { $_ // '[ERROR!]' } @_ ) . ')'; } sub do_R { return 'R(): I will never be called'; } sub do_S { shift; return 'S(' . ( join q{;}, map { $_ // '[ERROR!]' } @_ ) . ')'; } sub do_X { return 'X(' . $_[1] . ')'; } sub do_Y { return 'Y(' . $_[1] . ')'; } ## no critic (Variables::ProhibitPackageVars) our $null_A = 'null A'; our $null_B = 'null B'; our $null_L = 'null L'; our $null_R = 'null R'; our $null_X = 'null X'; our $null_Y = 'null Y'; ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', actions => 'main', rules => [ [ 'S', [qw/L R/], 'do_S' ], [ 'L', [qw/A B X/], 'do_L' ], [ 'L', [], 'null_L' ], [ 'R', [qw/A B Y/], 'do_R' ], [ 'R', [], 'null_R' ], [ 'A', [], 'null_A' ], [ 'B', [], 'null_B' ], [ 'X', [], 'null_X' ], [ 'X', [qw/x/], 'do_X' ], [ 'Y', [], 'null_Y' ], [ 'Y', [qw/y/], 'do_Y' ], ], } ); $grammar->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); $recce->read( 'x', 'x' ); # Marpa::R2::Display::End ## use critic # Marpa::R2::Display # name: Null Value Example Output # start-after-line: END_OF_OUTPUT # end-before-line: '^END_OF_OUTPUT$' chomp( my $expected = <<'END_OF_OUTPUT'); S(L(null A;null B;X(x));null R) END_OF_OUTPUT # Marpa::R2::Display::End my $value = $recce->value(); Marpa::R2::Test::is( ${$value}, $expected, 'Null example' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_json.t0000444000000000000000000002756612342464706015157 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test using a JSON parser # Inspired by a parser written by Peter Stuifzand use 5.010; use strict; use warnings; use Test::More tests => 14; use English qw( -no_match_vars ); use Scalar::Util qw(blessed); use lib 'inc'; use Marpa::R2::Test; ## no critic (ErrorHandling::RequireCarping); use Marpa::R2; my $p = MarpaX::JSON->new(); my $data = $p->parse_json(q${"test":"1"}$); is($data->{test}, 1); { my $test = q${"test":[1,2,3]}$; $data = $p->parse_json(q${"test":[1,2,3]}$); is_deeply( $data->{test}, [ 1, 2, 3 ], $test ); } $data = $p->parse_json(q${"test":true}$); is($data->{test}, 1); $data = $p->parse_json(q${"test":false}$); is($data->{test}, ''); $data = $p->parse_json(q${"test":null}$); is($data->{test}, undef); $data = $p->parse_json(q${"test":null, "test2":"hello world"}$); is($data->{test}, undef); is($data->{test2}, "hello world"); $data = $p->parse_json(q${"test":"1.25"}$); is($data->{test}, '1.25', '1.25'); $data = $p->parse_json(q${"test":"1.25e4"}$); is($data->{test}, '1.25e4', '1.25e4'); $data = $p->parse_json(q$[]$); is_deeply($data, [], '[]'); $data = $p->parse_json(<<'JSON'); [ { "precision": "zip", "Latitude": 37.7668, "Longitude": -122.3959, "Address": "", "City": "SAN FRANCISCO", "State": "CA", "Zip": "94107", "Country": "US" }, { "precision": "zip", "Latitude": 37.371991, "Longitude": -122.026020, "Address": "", "City": "SUNNYVALE", "State": "CA", "Zip": "94085", "Country": "US" } ] JSON is_deeply($data, [ { "precision"=>"zip", Latitude => "37.7668", Longitude=>"-122.3959", "Country" => "US", Zip => 94107, Address => '', City => "SAN FRANCISCO", State => 'CA' }, { "precision" => "zip", Longitude => "-122.026020", Address => "", City => "SUNNYVALE", Country => "US", Latitude => "37.371991", Zip => 94085, State => "CA" } ], 'Geo data'); $data = $p->parse_json(<<'JSON'); { "Image": { "Width": 800, "Height": 600, "Title": "View from 15th Floor", "Thumbnail": { "Url": "http://www.example.com/image/481989943", "Height": 125, "Width": "100" }, "IDs": [116, 943, 234, 38793] } } JSON is_deeply($data, { "Image" => { "Width" => 800, "Height" => 600, "Title" => "View from 15th Floor", "Thumbnail" => { "Url" => "http://www.example.com/image/481989943", "Height" => 125, "Width" => 100, }, "IDs" => [ 116, 943, 234, 38793 ], } }, 'is_deeply test'); my $big_test = <<'JSON'; { "source" : "Janetter", "entities" : { "user_mentions" : [ { "name" : "James Governor", "screen_name" : "moankchips", "indices" : [ 0, 10 ], "id_str" : "61233", "id" : 61233 } ], "media" : [ ], "hashtags" : [ ], "urls" : [ ] }, "in_reply_to_status_id_str" : "281400879465238529", "geo" : { }, "id_str" : "281405942321532929", "in_reply_to_user_id" : 61233, "text" : "@monkchips Ouch. Some regrets are harsher than others.", "id" : 281405942321532929, "in_reply_to_status_id" : 281400879465238529, "created_at" : "Wed Dec 19 14:29:39 +0000 2012", "in_reply_to_screen_name" : "monkchips", "in_reply_to_user_id_str" : "61233", "user" : { "name" : "Sarah Bourne", "screen_name" : "sarahebourne", "protected" : false, "id_str" : "16010789", "profile_image_url_https" : "https://si0.twimg.com/profile_images/638441870/Snapshot-of-sb_normal.jpg", "id" : 16010789, "verified" : false } } JSON $data = $p->parse_json($big_test); my $trace = $p->trace_json($big_test); is($trace, <<'END_OF_EXPECTED_TRACE', 'big test trace'); Line 2, column 5, lexeme , literal ""source"" Line 2, column 16, lexeme , literal ""Janetter"" Line 3, column 5, lexeme , literal ""entities"" Line 4, column 9, lexeme , literal ""user_mentions"" Line 5, column 17, lexeme , literal ""name"" Line 5, column 26, lexeme , literal ""James Governor"" Line 6, column 17, lexeme , literal ""screen_name"" Line 6, column 33, lexeme , literal ""moankchips"" Line 7, column 17, lexeme , literal ""indices"" Line 8, column 17, lexeme , literal ""id_str"" Line 8, column 28, lexeme , literal ""61233"" Line 9, column 17, lexeme , literal ""id"" Line 11, column 9, lexeme , literal ""media"" Line 12, column 9, lexeme , literal ""hashtags"" Line 13, column 9, lexeme , literal ""urls"" Line 15, column 5, lexeme , literal ""in_reply_to_status_id_str"" Line 15, column 35, lexeme , literal ""281400879465238529"" Line 16, column 5, lexeme , literal ""geo"" Line 18, column 5, lexeme , literal ""id_str"" Line 18, column 16, lexeme , literal ""281405942321532929"" Line 19, column 5, lexeme , literal ""in_reply_to_user_id"" Line 20, column 5, lexeme , literal ""text"" Line 20, column 14, lexeme , literal ""@monkchips Ouch. Some regrets are harsher than others."" Line 21, column 5, lexeme , literal ""id"" Line 22, column 5, lexeme , literal ""in_reply_to_status_id"" Line 23, column 5, lexeme , literal ""created_at"" Line 23, column 20, lexeme , literal ""Wed Dec 19 14:29:39 +0000 2012"" Line 24, column 5, lexeme , literal ""in_reply_to_screen_name"" Line 24, column 33, lexeme , literal ""monkchips"" Line 25, column 5, lexeme , literal ""in_reply_to_user_id_str"" Line 25, column 33, lexeme , literal ""61233"" Line 26, column 5, lexeme , literal ""user"" Line 27, column 9, lexeme , literal ""name"" Line 27, column 18, lexeme , literal ""Sarah Bourne"" Line 28, column 9, lexeme , literal ""screen_name"" Line 28, column 25, lexeme , literal ""sarahebourne"" Line 29, column 9, lexeme , literal ""protected"" Line 30, column 9, lexeme , literal ""id_str"" Line 30, column 20, lexeme , literal ""16010789"" Line 31, column 9, lexeme , literal ""profile_image_url_https"" Line 31, column 37, lexeme , literal ""https://si0.twimg.com/profile_images/638441870/Snapshot-of-sb_normal.jpg"" Line 32, column 9, lexeme , literal ""id"" Line 33, column 9, lexeme , literal ""verified"" END_OF_EXPECTED_TRACE $data = $p->parse_json(<<'JSON'); { "test": "\u2603" } JSON is($data->{test}, "\x{2603}", 'Unicode char'); package MarpaX::JSON; sub new { my ($class) = @_; my $parser = bless {}, $class; $parser->{grammar} = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :default ::= action => ::first :start ::= json json ::= object | array object ::= ('{') members ('}') action => do_object # comma is provided as a char class here, to ensure that char classes # as separators are in the test suite. members ::= pair* action => ::array separator => [,] pair ::= string (':') value action => ::array value ::= string | object | number | array | 'true' action => do_true | 'false' action => do_true | 'null' action => ::undef array ::= ('[' ']') action => [] | ('[') elements (']') # comma is provided as a char class here, to ensure that char classes # as separators are in the test suite. elements ::= value+ action => ::array separator => [,] number ~ int | int frac | int exp | int frac exp int ~ digits | '-' digits digits ~ [\d]+ frac ~ '.' digits exp ~ e digits e ~ 'e' | 'e+' | 'e-' | 'E' | 'E+' | 'E-' string ::= lstring :lexeme ~ lstring pause => before lstring ~ quote in_string quote quote ~ ["] in_string ~ in_string_char* in_string_char ~ [^"] | '\"' :discard ~ whitespace whitespace ~ [\s]+ END_OF_SOURCE } ); return $parser; } sub parse { my ( $parser, $string ) = @_; # Marpa::R2::Display # name: SLIF read/resume example my $re = Marpa::R2::Scanless::R->new( { grammar => $parser->{grammar}, semantics_package => 'MarpaX::JSON::Actions' } ); my $length = length $string; for ( my $pos = $re->read( \$string ); $pos < $length; $pos = $re->resume() ) { my ( $start, $length ) = $re->pause_span(); my $value = substr $string, $start + 1, $length - 2; $value = decode_string($value) if -1 != index $value, '\\'; $re->lexeme_read( 'lstring', $start, $length, $value ) // die; } ## end for ( my $pos = $re->read( \$string ); $pos < $length...) my $per_parse_arg = bless {}, 'MarpaX::JSON::Actions'; my $value_ref = $re->value($per_parse_arg); return ${$value_ref}; # Marpa::R2::Display::End } ## end sub parse sub parse_json { my ($parser, $string) = @_; return $parser->parse($string); } sub trace_json { my ($parser, $string) = @_; my $trace_desc = q{}; # Marpa::R2::Display # name: SLIF trace example my $re = Marpa::R2::Scanless::R->new( { grammar => $parser->{grammar} } ); my $length = length $string; for ( my $pos = $re->read( \$string ); $pos < $length; $pos = $re->resume() ) { my ( $start, $span_length ) = $re->pause_span(); my ( $line, $column ) = $re->line_column($start); my $lexeme = $re->pause_lexeme(); my $literal_string = $re->literal( $start, $span_length ); $trace_desc .= qq{Line $line, column $column, lexeme <$lexeme>, literal "$literal_string"\n}; my $value = substr $string, $start + 1, $span_length - 2; $value = decode_string($value) if -1 != index $value, q{\\}; $re->lexeme_read( 'lstring', $start, $span_length, $value ) // die; } ## end for ( my $pos = $re->read( \$string ); $pos < $length...) return $trace_desc; # Marpa::R2::Display::End } sub decode_string { my ($s) = @_; $s =~ s/\\u([0-9A-Fa-f]{4})/chr(hex($1))/egxms; $s =~ s/\\n/\n/gxms; $s =~ s/\\r/\r/gxms; $s =~ s/\\b/\b/gxms; $s =~ s/\\f/\f/gxms; $s =~ s/\\t/\t/gxms; $s =~ s/\\\\/\\/gxms; $s =~ s{\\/}{/}gxms; $s =~ s{\\"}{"}gxms; return $s; } ## end sub decode_string use strict; sub MarpaX::JSON::Actions::do_object { my (undef, $members) = @_; use Data::Dumper; return { map { @{$_} } @{$members} }; } sub MarpaX::JSON::Actions::do_true { shift; return $_[0] eq 'true'; } 1; Marpa-R2-2.086000~dfsg/t/ah2.t0000444000000000000000000002241512342464707014147 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # the example grammar in Aycock/Horspool "Practical Earley Parsing", # _The Computer Journal_, Vol. 45, No. 6, pp. 620-630, # in its "NNF" form use 5.010; use strict; use warnings; use Test::More tests => 25; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . ( join q{;}, @_ ) . ')'; } ## end sub default_action ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/A A A A/] ], [ 'A', [qw/a/] ], [ 'A', [qw/E/] ], ['E'], ], default_action => 'main::default_action', } ); $grammar->set( { terminals => ['a'], } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_rules, <<'EOS', 'Aycock/Horspool Rules' ); 0: S -> A A A A 1: A -> a 2: A -> E /* !used */ 3: E -> /* empty !used */ EOS Marpa::R2::Test::is( $grammar->show_symbols, <<'EOS', 'Aycock/Horspool Symbols' ); 0: S 1: A 2: a, terminal 3: E, nulling EOS Marpa::R2::Test::is( $grammar->show_isys, <<'EOS', 'Aycock/Horspool ISYs' ); 0: S 1: S[], nulling 2: A 3: A[], nulling 4: a 5: E[], nulling 6: S[R0:1] 7: S[R0:2] 8: S['] EOS Marpa::R2::Test::is( $grammar->show_irls, <<'EOS', 'Aycock/Horspool IRLs' ); 0: S -> A S[R0:1] 1: S -> A A[] A[] A[] 2: S -> A[] S[R0:1] 3: S[R0:1] -> A S[R0:2] 4: S[R0:1] -> A A[] A[] 5: S[R0:1] -> A[] S[R0:2] 6: S[R0:2] -> A A 7: S[R0:2] -> A A[] 8: S[R0:2] -> A[] A 9: A -> a 10: S['] -> S EOS Marpa::R2::Test::is( $grammar->show_nulling_symbols, q{E}, 'Aycock/Horspool Nulling Symbols' ); Marpa::R2::Test::is( $grammar->show_productive_symbols, q{A E S a}, 'Aycock/Horspool Productive Symbols' ); Marpa::R2::Test::is( $grammar->show_accessible_symbols, q{A E S a}, 'Aycock/Horspool Accessible Symbols' ); Marpa::R2::Test::is( $grammar->show_ahms(), <<'EOS', 'Aycock/Horspool AHMs' ); AHM 0: postdot = "A" S ::= . A S[R0:1] AHM 1: postdot = "S[R0:1]" S ::= A . S[R0:1] AHM 2: completion S ::= A S[R0:1] . AHM 3: postdot = "A" S ::= . A A[] A[] A[] AHM 4: completion S ::= A A[] A[] A[] . AHM 5: postdot = "S[R0:1]" S ::= A[] . S[R0:1] AHM 6: completion S ::= A[] S[R0:1] . AHM 7: postdot = "A" S[R0:1] ::= . A S[R0:2] AHM 8: postdot = "S[R0:2]" S[R0:1] ::= A . S[R0:2] AHM 9: completion S[R0:1] ::= A S[R0:2] . AHM 10: postdot = "A" S[R0:1] ::= . A A[] A[] AHM 11: completion S[R0:1] ::= A A[] A[] . AHM 12: postdot = "S[R0:2]" S[R0:1] ::= A[] . S[R0:2] AHM 13: completion S[R0:1] ::= A[] S[R0:2] . AHM 14: postdot = "A" S[R0:2] ::= . A A AHM 15: postdot = "A" S[R0:2] ::= A . A AHM 16: completion S[R0:2] ::= A A . AHM 17: postdot = "A" S[R0:2] ::= . A A[] AHM 18: completion S[R0:2] ::= A A[] . AHM 19: postdot = "A" S[R0:2] ::= A[] . A AHM 20: completion S[R0:2] ::= A[] A . AHM 21: postdot = "a" A ::= . a AHM 22: completion A ::= a . AHM 23: postdot = "S" S['] ::= . S AHM 24: completion S['] ::= S . EOS my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); my $expected_earley_sets = <<'END_OF_SETS'; Last Completed: 4; Furthest: 4 Earley Set 0 ahm23: R10:0@0-0 R10:0: S['] ::= . S ahm0: R0:0@0-0 R0:0: S ::= . A S[R0:1] ahm3: R1:0@0-0 R1:0: S ::= . A A[] A[] A[] ahm5: R2:1@0-0 R2:1: S ::= A[] . S[R0:1] ahm7: R3:0@0-0 R3:0: S[R0:1] ::= . A S[R0:2] ahm10: R4:0@0-0 R4:0: S[R0:1] ::= . A A[] A[] ahm12: R5:1@0-0 R5:1: S[R0:1] ::= A[] . S[R0:2] ahm14: R6:0@0-0 R6:0: S[R0:2] ::= . A A ahm17: R7:0@0-0 R7:0: S[R0:2] ::= . A A[] ahm19: R8:1@0-0 R8:1: S[R0:2] ::= A[] . A ahm21: R9:0@0-0 R9:0: A ::= . a Earley Set 1 ahm22: R9$@0-1 R9$: A ::= a . [c=R9:0@0-0; s=a; t=\'a'] ahm20: R8$@0-1 R8$: S[R0:2] ::= A[] A . [p=R8:1@0-0; c=R9$@0-1] ahm18: R7$@0-1 R7$: S[R0:2] ::= A A[] . [p=R7:0@0-0; c=R9$@0-1] ahm15: R6:1@0-1 R6:1: S[R0:2] ::= A . A [p=R6:0@0-0; c=R9$@0-1] ahm11: R4$@0-1 R4$: S[R0:1] ::= A A[] A[] . [p=R4:0@0-0; c=R9$@0-1] ahm8: R3:1@0-1 R3:1: S[R0:1] ::= A . S[R0:2] [p=R3:0@0-0; c=R9$@0-1] ahm4: R1$@0-1 R1$: S ::= A A[] A[] A[] . [p=R1:0@0-0; c=R9$@0-1] ahm1: R0:1@0-1 R0:1: S ::= A . S[R0:1] [p=R0:0@0-0; c=R9$@0-1] ahm24: R10$@0-1 R10$: S['] ::= S . [p=R10:0@0-0; c=R1$@0-1] [p=R10:0@0-0; c=R2$@0-1] ahm6: R2$@0-1 R2$: S ::= A[] S[R0:1] . [p=R2:1@0-0; c=R4$@0-1] [p=R2:1@0-0; c=R5$@0-1] ahm13: R5$@0-1 R5$: S[R0:1] ::= A[] S[R0:2] . [p=R5:1@0-0; c=R7$@0-1] [p=R5:1@0-0; c=R8$@0-1] ahm21: R9:0@1-1 R9:0: A ::= . a ahm14: R6:0@1-1 R6:0: S[R0:2] ::= . A A ahm17: R7:0@1-1 R7:0: S[R0:2] ::= . A A[] ahm19: R8:1@1-1 R8:1: S[R0:2] ::= A[] . A ahm7: R3:0@1-1 R3:0: S[R0:1] ::= . A S[R0:2] ahm10: R4:0@1-1 R4:0: S[R0:1] ::= . A A[] A[] ahm12: R5:1@1-1 R5:1: S[R0:1] ::= A[] . S[R0:2] Earley Set 2 ahm22: R9$@1-2 R9$: A ::= a . [c=R9:0@1-1; s=a; t=\'a'] ahm11: R4$@1-2 R4$: S[R0:1] ::= A A[] A[] . [p=R4:0@1-1; c=R9$@1-2] ahm8: R3:1@1-2 R3:1: S[R0:1] ::= A . S[R0:2] [p=R3:0@1-1; c=R9$@1-2] ahm20: R8$@1-2 R8$: S[R0:2] ::= A[] A . [p=R8:1@1-1; c=R9$@1-2] ahm18: R7$@1-2 R7$: S[R0:2] ::= A A[] . [p=R7:0@1-1; c=R9$@1-2] ahm15: R6:1@1-2 R6:1: S[R0:2] ::= A . A [p=R6:0@1-1; c=R9$@1-2] ahm16: R6$@0-2 R6$: S[R0:2] ::= A A . [p=R6:1@0-1; c=R9$@1-2] ahm13: R5$@0-2 R5$: S[R0:1] ::= A[] S[R0:2] . [p=R5:1@0-0; c=R6$@0-2] ahm6: R2$@0-2 R2$: S ::= A[] S[R0:1] . [p=R2:1@0-0; c=R3$@0-2] [p=R2:1@0-0; c=R5$@0-2] ahm24: R10$@0-2 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-2] [p=R10:0@0-0; c=R2$@0-2] ahm13: R5$@1-2 R5$: S[R0:1] ::= A[] S[R0:2] . [p=R5:1@1-1; c=R7$@1-2] [p=R5:1@1-1; c=R8$@1-2] ahm9: R3$@0-2 R3$: S[R0:1] ::= A S[R0:2] . [p=R3:1@0-1; c=R7$@1-2] [p=R3:1@0-1; c=R8$@1-2] ahm2: R0$@0-2 R0$: S ::= A S[R0:1] . [p=R0:1@0-1; c=R4$@1-2] [p=R0:1@0-1; c=R5$@1-2] ahm14: R6:0@2-2 R6:0: S[R0:2] ::= . A A ahm17: R7:0@2-2 R7:0: S[R0:2] ::= . A A[] ahm19: R8:1@2-2 R8:1: S[R0:2] ::= A[] . A ahm21: R9:0@2-2 R9:0: A ::= . a Earley Set 3 ahm22: R9$@2-3 R9$: A ::= a . [c=R9:0@2-2; s=a; t=\'a'] ahm20: R8$@2-3 R8$: S[R0:2] ::= A[] A . [p=R8:1@2-2; c=R9$@2-3] ahm18: R7$@2-3 R7$: S[R0:2] ::= A A[] . [p=R7:0@2-2; c=R9$@2-3] ahm15: R6:1@2-3 R6:1: S[R0:2] ::= A . A [p=R6:0@2-2; c=R9$@2-3] ahm16: R6$@1-3 R6$: S[R0:2] ::= A A . [p=R6:1@1-2; c=R9$@2-3] ahm13: R5$@1-3 R5$: S[R0:1] ::= A[] S[R0:2] . [p=R5:1@1-1; c=R6$@1-3] ahm9: R3$@0-3 R3$: S[R0:1] ::= A S[R0:2] . [p=R3:1@0-1; c=R6$@1-3] ahm6: R2$@0-3 R2$: S ::= A[] S[R0:1] . [p=R2:1@0-0; c=R3$@0-3] ahm24: R10$@0-3 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-3] [p=R10:0@0-0; c=R2$@0-3] ahm2: R0$@0-3 R0$: S ::= A S[R0:1] . [p=R0:1@0-1; c=R3$@1-3] [p=R0:1@0-1; c=R5$@1-3] ahm9: R3$@1-3 R3$: S[R0:1] ::= A S[R0:2] . [p=R3:1@1-2; c=R7$@2-3] [p=R3:1@1-2; c=R8$@2-3] ahm21: R9:0@3-3 R9:0: A ::= . a Earley Set 4 ahm22: R9$@3-4 R9$: A ::= a . [c=R9:0@3-3; s=a; t=\'a'] ahm16: R6$@2-4 R6$: S[R0:2] ::= A A . [p=R6:1@2-3; c=R9$@3-4] ahm9: R3$@1-4 R3$: S[R0:1] ::= A S[R0:2] . [p=R3:1@1-2; c=R6$@2-4] ahm2: R0$@0-4 R0$: S ::= A S[R0:1] . [p=R0:1@0-1; c=R3$@1-4] ahm24: R10$@0-4 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-4] END_OF_SETS my $input_length = 4; for (my $i = 0; $i < $input_length; $i++) { $recce->read( 'a', 'a' ); } Marpa::R2::Test::is( $recce->show_earley_sets(2), $expected_earley_sets, 'Aycock/Horspool Earley sets' ); my @expected = map { +{ map { ( $_ => 1 ) } @{$_} } } [q{}], [qw( (a;;;) (;a;;) (;;a;) (;;;a) )], [qw( (a;a;;) (a;;a;) (a;;;a) (;a;a;) (;a;;a) (;;a;a) )], [qw( (a;a;a;) (a;a;;a) (a;;a;a) (;a;a;a) )], ['(a;a;a;a)']; $recce->set( { max_parses => 20 } ); for my $i ( 0 .. $input_length ) { $recce->reset_evaluation(); $recce->set( { end => $i } ); my $expected = $expected[$i]; while ( my $value_ref = $recce->value() ) { my $value = $value_ref ? ${$value_ref} : 'No parse'; if ( defined $expected->{$value} ) { delete $expected->{$value}; Test::More::pass(qq{Expected result for length=$i, "$value"}); } else { Test::More::fail(qq{Unexpected result for length=$i, "$value"}); } } ## end while ( my $value_ref = $recce->value() ) for my $value ( keys %{$expected} ) { Test::More::fail(qq{Missing result for length=$i, "$value"}); } } ## end for my $i ( 0 .. $input_length ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/leo_cycle.t0000444000000000000000000005245612342464707015443 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # This is based on the # example from p. 166 of Leo's paper, # augmented to test Leo prediction items, # as well as a long cycle of Leo items use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Test::More tests => 6; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; sub main::default_action { shift; return ( join q{}, grep {defined} @_ ); } my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/a A/] ], [ 'H', [qw/S/] ], [ 'B', [qw/C/] ], [ 'D', [qw/E/] ], [ 'E', [qw/F/] ], [ 'F', [qw/G/] ], [ 'C', [qw/D/] ], [ 'G', [qw/H/] ], [ 'A', [qw/B/] ], [ 'S', [], ], ], terminals => [qw(a)], default_action => 'main::default_action', } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_symbols(), <<'END_OF_STRING', 'Leo166 Symbols' ); 0: a, terminal 1: S 2: A 3: H 4: B 5: C 6: D 7: E 8: F 9: G END_OF_STRING Marpa::R2::Test::is( $grammar->show_rules, <<'END_OF_STRING', 'Leo166 Rules' ); 0: S -> a A 1: H -> S 2: B -> C 3: D -> E 4: E -> F 5: F -> G 6: C -> D 7: G -> H 8: A -> B 9: S -> /* empty !used */ END_OF_STRING my $expected_ahms_output = <<'END_OF_STRING'; AHM 0: postdot = "a" S ::= . a A AHM 1: postdot = "A" S ::= a . A AHM 2: completion S ::= a A . AHM 3: postdot = "a" S ::= . a A[] AHM 4: completion S ::= a A[] . AHM 5: postdot = "S" H ::= . S AHM 6: completion H ::= S . AHM 7: postdot = "C" B ::= . C AHM 8: completion B ::= C . AHM 9: postdot = "E" D ::= . E AHM 10: completion D ::= E . AHM 11: postdot = "F" E ::= . F AHM 12: completion E ::= F . AHM 13: postdot = "G" F ::= . G AHM 14: completion F ::= G . AHM 15: postdot = "D" C ::= . D AHM 16: completion C ::= D . AHM 17: postdot = "H" G ::= . H AHM 18: completion G ::= H . AHM 19: postdot = "B" A ::= . B AHM 20: completion A ::= B . AHM 21: postdot = "S" S['] ::= . S AHM 22: completion S['] ::= S . END_OF_STRING Marpa::R2::Test::is( $grammar->show_ahms(), $expected_ahms_output, 'Leo166 AHFA' ); my $length = 20; my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); my $i = 0; my $latest_earley_set = $recce->latest_earley_set(); my $max_size = $recce->earley_set_size($latest_earley_set); TOKEN: while ( $i++ < $length ) { $recce->read( 'a', 'a' ); $latest_earley_set = $recce->latest_earley_set(); my $size = $recce->earley_set_size($latest_earley_set); $max_size = $size > $max_size ? $size : $max_size; } ## end while ( $i++ < $length ) # Note that the length formula only works # beginning with Earley set c, for some small # constant c my $expected_size = 14; Marpa::R2::Test::is( $max_size, $expected_size, "size $max_size" ); my $show_earley_sets_output = do { local $RS = undef; ## no critic(Subroutines::ProhibitCallsToUndeclaredSubs) ; }; Marpa::R2::Test::is( $recce->show_earley_sets(1), $show_earley_sets_output, 'Leo cycle Earley sets' ); my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; Marpa::R2::Test::is( $value, 'a' x $length, 'Leo cycle parse' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: __DATA__ Last Completed: 20; Furthest: 20 Earley Set 0 ahm21: R10:0@0-0 R10:0: S['] ::= . S ahm0: R0:0@0-0 R0:0: S ::= . a A ahm3: R1:0@0-0 R1:0: S ::= . a A[] Earley Set 1 ahm4: R1$@0-1 R1$: S ::= a A[] . [c=R1:0@0-0; s=a; t=\'a'] ahm1: R0:1@0-1 R0:1: S ::= a . A [c=R0:0@0-0; s=a; t=\'a'] ahm22: R10$@0-1 R10$: S['] ::= S . [p=R10:0@0-0; c=R1$@0-1] ahm0: R0:0@1-1 R0:0: S ::= . a A ahm3: R1:0@1-1 R1:0: S ::= . a A[] ahm5: R2:0@1-1 R2:0: H ::= . S ahm7: R3:0@1-1 R3:0: B ::= . C ahm9: R4:0@1-1 R4:0: D ::= . E ahm11: R5:0@1-1 R5:0: E ::= . F ahm13: R6:0@1-1 R6:0: F ::= . G ahm15: R7:0@1-1 R7:0: C ::= . D ahm17: R8:0@1-1 R8:0: G ::= . H ahm19: R9:0@1-1 R9:0: A ::= . B L1@1 ["S"; L5@1; S5@1-1] L3@1 ["A"; S1@0-1] L5@1 ["H"; L17@1; S17@1-1] L7@1 ["B"; L3@1; S19@1-1] L9@1 ["C"; L7@1; S7@1-1] L11@1 ["D"; L9@1; S15@1-1] L13@1 ["E"; L11@1; S9@1-1] L15@1 ["F"; L13@1; S11@1-1] L17@1 ["G"; L15@1; S13@1-1] Earley Set 2 ahm4: R1$@1-2 R1$: S ::= a A[] . [c=R1:0@1-1; s=a; t=\'a'] ahm1: R0:1@1-2 R0:1: S ::= a . A [c=R0:0@1-1; s=a; t=\'a'] ahm2: R0$@0-2 R0$: S ::= a A . [l=L1@1; c=R1$@1-2] ahm22: R10$@0-2 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-2] ahm0: R0:0@2-2 R0:0: S ::= . a A ahm3: R1:0@2-2 R1:0: S ::= . a A[] ahm5: R2:0@2-2 R2:0: H ::= . S ahm7: R3:0@2-2 R3:0: B ::= . C ahm9: R4:0@2-2 R4:0: D ::= . E ahm11: R5:0@2-2 R5:0: E ::= . F ahm13: R6:0@2-2 R6:0: F ::= . G ahm15: R7:0@2-2 R7:0: C ::= . D ahm17: R8:0@2-2 R8:0: G ::= . H ahm19: R9:0@2-2 R9:0: A ::= . B L1@2 ["S"; L5@2; S5@2-2] L3@2 ["A"; L1@1; S1@1-2] L5@2 ["H"; L17@2; S17@2-2] L7@2 ["B"; L3@2; S19@2-2] L9@2 ["C"; L7@2; S7@2-2] L11@2 ["D"; L9@2; S15@2-2] L13@2 ["E"; L11@2; S9@2-2] L15@2 ["F"; L13@2; S11@2-2] L17@2 ["G"; L15@2; S13@2-2] Earley Set 3 ahm4: R1$@2-3 R1$: S ::= a A[] . [c=R1:0@2-2; s=a; t=\'a'] ahm1: R0:1@2-3 R0:1: S ::= a . A [c=R0:0@2-2; s=a; t=\'a'] ahm2: R0$@0-3 R0$: S ::= a A . [l=L1@2; c=R1$@2-3] ahm22: R10$@0-3 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-3] ahm0: R0:0@3-3 R0:0: S ::= . a A ahm3: R1:0@3-3 R1:0: S ::= . a A[] ahm5: R2:0@3-3 R2:0: H ::= . S ahm7: R3:0@3-3 R3:0: B ::= . C ahm9: R4:0@3-3 R4:0: D ::= . E ahm11: R5:0@3-3 R5:0: E ::= . F ahm13: R6:0@3-3 R6:0: F ::= . G ahm15: R7:0@3-3 R7:0: C ::= . D ahm17: R8:0@3-3 R8:0: G ::= . H ahm19: R9:0@3-3 R9:0: A ::= . B L1@3 ["S"; L5@3; S5@3-3] L3@3 ["A"; L1@2; S1@2-3] L5@3 ["H"; L17@3; S17@3-3] L7@3 ["B"; L3@3; S19@3-3] L9@3 ["C"; L7@3; S7@3-3] L11@3 ["D"; L9@3; S15@3-3] L13@3 ["E"; L11@3; S9@3-3] L15@3 ["F"; L13@3; S11@3-3] L17@3 ["G"; L15@3; S13@3-3] Earley Set 4 ahm4: R1$@3-4 R1$: S ::= a A[] . [c=R1:0@3-3; s=a; t=\'a'] ahm1: R0:1@3-4 R0:1: S ::= a . A [c=R0:0@3-3; s=a; t=\'a'] ahm2: R0$@0-4 R0$: S ::= a A . [l=L1@3; c=R1$@3-4] ahm22: R10$@0-4 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-4] ahm0: R0:0@4-4 R0:0: S ::= . a A ahm3: R1:0@4-4 R1:0: S ::= . a A[] ahm5: R2:0@4-4 R2:0: H ::= . S ahm7: R3:0@4-4 R3:0: B ::= . C ahm9: R4:0@4-4 R4:0: D ::= . E ahm11: R5:0@4-4 R5:0: E ::= . F ahm13: R6:0@4-4 R6:0: F ::= . G ahm15: R7:0@4-4 R7:0: C ::= . D ahm17: R8:0@4-4 R8:0: G ::= . H ahm19: R9:0@4-4 R9:0: A ::= . B L1@4 ["S"; L5@4; S5@4-4] L3@4 ["A"; L1@3; S1@3-4] L5@4 ["H"; L17@4; S17@4-4] L7@4 ["B"; L3@4; S19@4-4] L9@4 ["C"; L7@4; S7@4-4] L11@4 ["D"; L9@4; S15@4-4] L13@4 ["E"; L11@4; S9@4-4] L15@4 ["F"; L13@4; S11@4-4] L17@4 ["G"; L15@4; S13@4-4] Earley Set 5 ahm4: R1$@4-5 R1$: S ::= a A[] . [c=R1:0@4-4; s=a; t=\'a'] ahm1: R0:1@4-5 R0:1: S ::= a . A [c=R0:0@4-4; s=a; t=\'a'] ahm2: R0$@0-5 R0$: S ::= a A . [l=L1@4; c=R1$@4-5] ahm22: R10$@0-5 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-5] ahm0: R0:0@5-5 R0:0: S ::= . a A ahm3: R1:0@5-5 R1:0: S ::= . a A[] ahm5: R2:0@5-5 R2:0: H ::= . S ahm7: R3:0@5-5 R3:0: B ::= . C ahm9: R4:0@5-5 R4:0: D ::= . E ahm11: R5:0@5-5 R5:0: E ::= . F ahm13: R6:0@5-5 R6:0: F ::= . G ahm15: R7:0@5-5 R7:0: C ::= . D ahm17: R8:0@5-5 R8:0: G ::= . H ahm19: R9:0@5-5 R9:0: A ::= . B L1@5 ["S"; L5@5; S5@5-5] L3@5 ["A"; L1@4; S1@4-5] L5@5 ["H"; L17@5; S17@5-5] L7@5 ["B"; L3@5; S19@5-5] L9@5 ["C"; L7@5; S7@5-5] L11@5 ["D"; L9@5; S15@5-5] L13@5 ["E"; L11@5; S9@5-5] L15@5 ["F"; L13@5; S11@5-5] L17@5 ["G"; L15@5; S13@5-5] Earley Set 6 ahm4: R1$@5-6 R1$: S ::= a A[] . [c=R1:0@5-5; s=a; t=\'a'] ahm1: R0:1@5-6 R0:1: S ::= a . A [c=R0:0@5-5; s=a; t=\'a'] ahm2: R0$@0-6 R0$: S ::= a A . [l=L1@5; c=R1$@5-6] ahm22: R10$@0-6 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-6] ahm0: R0:0@6-6 R0:0: S ::= . a A ahm3: R1:0@6-6 R1:0: S ::= . a A[] ahm5: R2:0@6-6 R2:0: H ::= . S ahm7: R3:0@6-6 R3:0: B ::= . C ahm9: R4:0@6-6 R4:0: D ::= . E ahm11: R5:0@6-6 R5:0: E ::= . F ahm13: R6:0@6-6 R6:0: F ::= . G ahm15: R7:0@6-6 R7:0: C ::= . D ahm17: R8:0@6-6 R8:0: G ::= . H ahm19: R9:0@6-6 R9:0: A ::= . B L1@6 ["S"; L5@6; S5@6-6] L3@6 ["A"; L1@5; S1@5-6] L5@6 ["H"; L17@6; S17@6-6] L7@6 ["B"; L3@6; S19@6-6] L9@6 ["C"; L7@6; S7@6-6] L11@6 ["D"; L9@6; S15@6-6] L13@6 ["E"; L11@6; S9@6-6] L15@6 ["F"; L13@6; S11@6-6] L17@6 ["G"; L15@6; S13@6-6] Earley Set 7 ahm4: R1$@6-7 R1$: S ::= a A[] . [c=R1:0@6-6; s=a; t=\'a'] ahm1: R0:1@6-7 R0:1: S ::= a . A [c=R0:0@6-6; s=a; t=\'a'] ahm2: R0$@0-7 R0$: S ::= a A . [l=L1@6; c=R1$@6-7] ahm22: R10$@0-7 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-7] ahm0: R0:0@7-7 R0:0: S ::= . a A ahm3: R1:0@7-7 R1:0: S ::= . a A[] ahm5: R2:0@7-7 R2:0: H ::= . S ahm7: R3:0@7-7 R3:0: B ::= . C ahm9: R4:0@7-7 R4:0: D ::= . E ahm11: R5:0@7-7 R5:0: E ::= . F ahm13: R6:0@7-7 R6:0: F ::= . G ahm15: R7:0@7-7 R7:0: C ::= . D ahm17: R8:0@7-7 R8:0: G ::= . H ahm19: R9:0@7-7 R9:0: A ::= . B L1@7 ["S"; L5@7; S5@7-7] L3@7 ["A"; L1@6; S1@6-7] L5@7 ["H"; L17@7; S17@7-7] L7@7 ["B"; L3@7; S19@7-7] L9@7 ["C"; L7@7; S7@7-7] L11@7 ["D"; L9@7; S15@7-7] L13@7 ["E"; L11@7; S9@7-7] L15@7 ["F"; L13@7; S11@7-7] L17@7 ["G"; L15@7; S13@7-7] Earley Set 8 ahm4: R1$@7-8 R1$: S ::= a A[] . [c=R1:0@7-7; s=a; t=\'a'] ahm1: R0:1@7-8 R0:1: S ::= a . A [c=R0:0@7-7; s=a; t=\'a'] ahm2: R0$@0-8 R0$: S ::= a A . [l=L1@7; c=R1$@7-8] ahm22: R10$@0-8 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-8] ahm0: R0:0@8-8 R0:0: S ::= . a A ahm3: R1:0@8-8 R1:0: S ::= . a A[] ahm5: R2:0@8-8 R2:0: H ::= . S ahm7: R3:0@8-8 R3:0: B ::= . C ahm9: R4:0@8-8 R4:0: D ::= . E ahm11: R5:0@8-8 R5:0: E ::= . F ahm13: R6:0@8-8 R6:0: F ::= . G ahm15: R7:0@8-8 R7:0: C ::= . D ahm17: R8:0@8-8 R8:0: G ::= . H ahm19: R9:0@8-8 R9:0: A ::= . B L1@8 ["S"; L5@8; S5@8-8] L3@8 ["A"; L1@7; S1@7-8] L5@8 ["H"; L17@8; S17@8-8] L7@8 ["B"; L3@8; S19@8-8] L9@8 ["C"; L7@8; S7@8-8] L11@8 ["D"; L9@8; S15@8-8] L13@8 ["E"; L11@8; S9@8-8] L15@8 ["F"; L13@8; S11@8-8] L17@8 ["G"; L15@8; S13@8-8] Earley Set 9 ahm4: R1$@8-9 R1$: S ::= a A[] . [c=R1:0@8-8; s=a; t=\'a'] ahm1: R0:1@8-9 R0:1: S ::= a . A [c=R0:0@8-8; s=a; t=\'a'] ahm2: R0$@0-9 R0$: S ::= a A . [l=L1@8; c=R1$@8-9] ahm22: R10$@0-9 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-9] ahm0: R0:0@9-9 R0:0: S ::= . a A ahm3: R1:0@9-9 R1:0: S ::= . a A[] ahm5: R2:0@9-9 R2:0: H ::= . S ahm7: R3:0@9-9 R3:0: B ::= . C ahm9: R4:0@9-9 R4:0: D ::= . E ahm11: R5:0@9-9 R5:0: E ::= . F ahm13: R6:0@9-9 R6:0: F ::= . G ahm15: R7:0@9-9 R7:0: C ::= . D ahm17: R8:0@9-9 R8:0: G ::= . H ahm19: R9:0@9-9 R9:0: A ::= . B L1@9 ["S"; L5@9; S5@9-9] L3@9 ["A"; L1@8; S1@8-9] L5@9 ["H"; L17@9; S17@9-9] L7@9 ["B"; L3@9; S19@9-9] L9@9 ["C"; L7@9; S7@9-9] L11@9 ["D"; L9@9; S15@9-9] L13@9 ["E"; L11@9; S9@9-9] L15@9 ["F"; L13@9; S11@9-9] L17@9 ["G"; L15@9; S13@9-9] Earley Set 10 ahm4: R1$@9-10 R1$: S ::= a A[] . [c=R1:0@9-9; s=a; t=\'a'] ahm1: R0:1@9-10 R0:1: S ::= a . A [c=R0:0@9-9; s=a; t=\'a'] ahm2: R0$@0-10 R0$: S ::= a A . [l=L1@9; c=R1$@9-10] ahm22: R10$@0-10 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-10] ahm0: R0:0@10-10 R0:0: S ::= . a A ahm3: R1:0@10-10 R1:0: S ::= . a A[] ahm5: R2:0@10-10 R2:0: H ::= . S ahm7: R3:0@10-10 R3:0: B ::= . C ahm9: R4:0@10-10 R4:0: D ::= . E ahm11: R5:0@10-10 R5:0: E ::= . F ahm13: R6:0@10-10 R6:0: F ::= . G ahm15: R7:0@10-10 R7:0: C ::= . D ahm17: R8:0@10-10 R8:0: G ::= . H ahm19: R9:0@10-10 R9:0: A ::= . B L1@10 ["S"; L5@10; S5@10-10] L3@10 ["A"; L1@9; S1@9-10] L5@10 ["H"; L17@10; S17@10-10] L7@10 ["B"; L3@10; S19@10-10] L9@10 ["C"; L7@10; S7@10-10] L11@10 ["D"; L9@10; S15@10-10] L13@10 ["E"; L11@10; S9@10-10] L15@10 ["F"; L13@10; S11@10-10] L17@10 ["G"; L15@10; S13@10-10] Earley Set 11 ahm4: R1$@10-11 R1$: S ::= a A[] . [c=R1:0@10-10; s=a; t=\'a'] ahm1: R0:1@10-11 R0:1: S ::= a . A [c=R0:0@10-10; s=a; t=\'a'] ahm2: R0$@0-11 R0$: S ::= a A . [l=L1@10; c=R1$@10-11] ahm22: R10$@0-11 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-11] ahm0: R0:0@11-11 R0:0: S ::= . a A ahm3: R1:0@11-11 R1:0: S ::= . a A[] ahm5: R2:0@11-11 R2:0: H ::= . S ahm7: R3:0@11-11 R3:0: B ::= . C ahm9: R4:0@11-11 R4:0: D ::= . E ahm11: R5:0@11-11 R5:0: E ::= . F ahm13: R6:0@11-11 R6:0: F ::= . G ahm15: R7:0@11-11 R7:0: C ::= . D ahm17: R8:0@11-11 R8:0: G ::= . H ahm19: R9:0@11-11 R9:0: A ::= . B L1@11 ["S"; L5@11; S5@11-11] L3@11 ["A"; L1@10; S1@10-11] L5@11 ["H"; L17@11; S17@11-11] L7@11 ["B"; L3@11; S19@11-11] L9@11 ["C"; L7@11; S7@11-11] L11@11 ["D"; L9@11; S15@11-11] L13@11 ["E"; L11@11; S9@11-11] L15@11 ["F"; L13@11; S11@11-11] L17@11 ["G"; L15@11; S13@11-11] Earley Set 12 ahm4: R1$@11-12 R1$: S ::= a A[] . [c=R1:0@11-11; s=a; t=\'a'] ahm1: R0:1@11-12 R0:1: S ::= a . A [c=R0:0@11-11; s=a; t=\'a'] ahm2: R0$@0-12 R0$: S ::= a A . [l=L1@11; c=R1$@11-12] ahm22: R10$@0-12 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-12] ahm0: R0:0@12-12 R0:0: S ::= . a A ahm3: R1:0@12-12 R1:0: S ::= . a A[] ahm5: R2:0@12-12 R2:0: H ::= . S ahm7: R3:0@12-12 R3:0: B ::= . C ahm9: R4:0@12-12 R4:0: D ::= . E ahm11: R5:0@12-12 R5:0: E ::= . F ahm13: R6:0@12-12 R6:0: F ::= . G ahm15: R7:0@12-12 R7:0: C ::= . D ahm17: R8:0@12-12 R8:0: G ::= . H ahm19: R9:0@12-12 R9:0: A ::= . B L1@12 ["S"; L5@12; S5@12-12] L3@12 ["A"; L1@11; S1@11-12] L5@12 ["H"; L17@12; S17@12-12] L7@12 ["B"; L3@12; S19@12-12] L9@12 ["C"; L7@12; S7@12-12] L11@12 ["D"; L9@12; S15@12-12] L13@12 ["E"; L11@12; S9@12-12] L15@12 ["F"; L13@12; S11@12-12] L17@12 ["G"; L15@12; S13@12-12] Earley Set 13 ahm4: R1$@12-13 R1$: S ::= a A[] . [c=R1:0@12-12; s=a; t=\'a'] ahm1: R0:1@12-13 R0:1: S ::= a . A [c=R0:0@12-12; s=a; t=\'a'] ahm2: R0$@0-13 R0$: S ::= a A . [l=L1@12; c=R1$@12-13] ahm22: R10$@0-13 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-13] ahm0: R0:0@13-13 R0:0: S ::= . a A ahm3: R1:0@13-13 R1:0: S ::= . a A[] ahm5: R2:0@13-13 R2:0: H ::= . S ahm7: R3:0@13-13 R3:0: B ::= . C ahm9: R4:0@13-13 R4:0: D ::= . E ahm11: R5:0@13-13 R5:0: E ::= . F ahm13: R6:0@13-13 R6:0: F ::= . G ahm15: R7:0@13-13 R7:0: C ::= . D ahm17: R8:0@13-13 R8:0: G ::= . H ahm19: R9:0@13-13 R9:0: A ::= . B L1@13 ["S"; L5@13; S5@13-13] L3@13 ["A"; L1@12; S1@12-13] L5@13 ["H"; L17@13; S17@13-13] L7@13 ["B"; L3@13; S19@13-13] L9@13 ["C"; L7@13; S7@13-13] L11@13 ["D"; L9@13; S15@13-13] L13@13 ["E"; L11@13; S9@13-13] L15@13 ["F"; L13@13; S11@13-13] L17@13 ["G"; L15@13; S13@13-13] Earley Set 14 ahm4: R1$@13-14 R1$: S ::= a A[] . [c=R1:0@13-13; s=a; t=\'a'] ahm1: R0:1@13-14 R0:1: S ::= a . A [c=R0:0@13-13; s=a; t=\'a'] ahm2: R0$@0-14 R0$: S ::= a A . [l=L1@13; c=R1$@13-14] ahm22: R10$@0-14 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-14] ahm0: R0:0@14-14 R0:0: S ::= . a A ahm3: R1:0@14-14 R1:0: S ::= . a A[] ahm5: R2:0@14-14 R2:0: H ::= . S ahm7: R3:0@14-14 R3:0: B ::= . C ahm9: R4:0@14-14 R4:0: D ::= . E ahm11: R5:0@14-14 R5:0: E ::= . F ahm13: R6:0@14-14 R6:0: F ::= . G ahm15: R7:0@14-14 R7:0: C ::= . D ahm17: R8:0@14-14 R8:0: G ::= . H ahm19: R9:0@14-14 R9:0: A ::= . B L1@14 ["S"; L5@14; S5@14-14] L3@14 ["A"; L1@13; S1@13-14] L5@14 ["H"; L17@14; S17@14-14] L7@14 ["B"; L3@14; S19@14-14] L9@14 ["C"; L7@14; S7@14-14] L11@14 ["D"; L9@14; S15@14-14] L13@14 ["E"; L11@14; S9@14-14] L15@14 ["F"; L13@14; S11@14-14] L17@14 ["G"; L15@14; S13@14-14] Earley Set 15 ahm4: R1$@14-15 R1$: S ::= a A[] . [c=R1:0@14-14; s=a; t=\'a'] ahm1: R0:1@14-15 R0:1: S ::= a . A [c=R0:0@14-14; s=a; t=\'a'] ahm2: R0$@0-15 R0$: S ::= a A . [l=L1@14; c=R1$@14-15] ahm22: R10$@0-15 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-15] ahm0: R0:0@15-15 R0:0: S ::= . a A ahm3: R1:0@15-15 R1:0: S ::= . a A[] ahm5: R2:0@15-15 R2:0: H ::= . S ahm7: R3:0@15-15 R3:0: B ::= . C ahm9: R4:0@15-15 R4:0: D ::= . E ahm11: R5:0@15-15 R5:0: E ::= . F ahm13: R6:0@15-15 R6:0: F ::= . G ahm15: R7:0@15-15 R7:0: C ::= . D ahm17: R8:0@15-15 R8:0: G ::= . H ahm19: R9:0@15-15 R9:0: A ::= . B L1@15 ["S"; L5@15; S5@15-15] L3@15 ["A"; L1@14; S1@14-15] L5@15 ["H"; L17@15; S17@15-15] L7@15 ["B"; L3@15; S19@15-15] L9@15 ["C"; L7@15; S7@15-15] L11@15 ["D"; L9@15; S15@15-15] L13@15 ["E"; L11@15; S9@15-15] L15@15 ["F"; L13@15; S11@15-15] L17@15 ["G"; L15@15; S13@15-15] Earley Set 16 ahm4: R1$@15-16 R1$: S ::= a A[] . [c=R1:0@15-15; s=a; t=\'a'] ahm1: R0:1@15-16 R0:1: S ::= a . A [c=R0:0@15-15; s=a; t=\'a'] ahm2: R0$@0-16 R0$: S ::= a A . [l=L1@15; c=R1$@15-16] ahm22: R10$@0-16 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-16] ahm0: R0:0@16-16 R0:0: S ::= . a A ahm3: R1:0@16-16 R1:0: S ::= . a A[] ahm5: R2:0@16-16 R2:0: H ::= . S ahm7: R3:0@16-16 R3:0: B ::= . C ahm9: R4:0@16-16 R4:0: D ::= . E ahm11: R5:0@16-16 R5:0: E ::= . F ahm13: R6:0@16-16 R6:0: F ::= . G ahm15: R7:0@16-16 R7:0: C ::= . D ahm17: R8:0@16-16 R8:0: G ::= . H ahm19: R9:0@16-16 R9:0: A ::= . B L1@16 ["S"; L5@16; S5@16-16] L3@16 ["A"; L1@15; S1@15-16] L5@16 ["H"; L17@16; S17@16-16] L7@16 ["B"; L3@16; S19@16-16] L9@16 ["C"; L7@16; S7@16-16] L11@16 ["D"; L9@16; S15@16-16] L13@16 ["E"; L11@16; S9@16-16] L15@16 ["F"; L13@16; S11@16-16] L17@16 ["G"; L15@16; S13@16-16] Earley Set 17 ahm4: R1$@16-17 R1$: S ::= a A[] . [c=R1:0@16-16; s=a; t=\'a'] ahm1: R0:1@16-17 R0:1: S ::= a . A [c=R0:0@16-16; s=a; t=\'a'] ahm2: R0$@0-17 R0$: S ::= a A . [l=L1@16; c=R1$@16-17] ahm22: R10$@0-17 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-17] ahm0: R0:0@17-17 R0:0: S ::= . a A ahm3: R1:0@17-17 R1:0: S ::= . a A[] ahm5: R2:0@17-17 R2:0: H ::= . S ahm7: R3:0@17-17 R3:0: B ::= . C ahm9: R4:0@17-17 R4:0: D ::= . E ahm11: R5:0@17-17 R5:0: E ::= . F ahm13: R6:0@17-17 R6:0: F ::= . G ahm15: R7:0@17-17 R7:0: C ::= . D ahm17: R8:0@17-17 R8:0: G ::= . H ahm19: R9:0@17-17 R9:0: A ::= . B L1@17 ["S"; L5@17; S5@17-17] L3@17 ["A"; L1@16; S1@16-17] L5@17 ["H"; L17@17; S17@17-17] L7@17 ["B"; L3@17; S19@17-17] L9@17 ["C"; L7@17; S7@17-17] L11@17 ["D"; L9@17; S15@17-17] L13@17 ["E"; L11@17; S9@17-17] L15@17 ["F"; L13@17; S11@17-17] L17@17 ["G"; L15@17; S13@17-17] Earley Set 18 ahm4: R1$@17-18 R1$: S ::= a A[] . [c=R1:0@17-17; s=a; t=\'a'] ahm1: R0:1@17-18 R0:1: S ::= a . A [c=R0:0@17-17; s=a; t=\'a'] ahm2: R0$@0-18 R0$: S ::= a A . [l=L1@17; c=R1$@17-18] ahm22: R10$@0-18 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-18] ahm0: R0:0@18-18 R0:0: S ::= . a A ahm3: R1:0@18-18 R1:0: S ::= . a A[] ahm5: R2:0@18-18 R2:0: H ::= . S ahm7: R3:0@18-18 R3:0: B ::= . C ahm9: R4:0@18-18 R4:0: D ::= . E ahm11: R5:0@18-18 R5:0: E ::= . F ahm13: R6:0@18-18 R6:0: F ::= . G ahm15: R7:0@18-18 R7:0: C ::= . D ahm17: R8:0@18-18 R8:0: G ::= . H ahm19: R9:0@18-18 R9:0: A ::= . B L1@18 ["S"; L5@18; S5@18-18] L3@18 ["A"; L1@17; S1@17-18] L5@18 ["H"; L17@18; S17@18-18] L7@18 ["B"; L3@18; S19@18-18] L9@18 ["C"; L7@18; S7@18-18] L11@18 ["D"; L9@18; S15@18-18] L13@18 ["E"; L11@18; S9@18-18] L15@18 ["F"; L13@18; S11@18-18] L17@18 ["G"; L15@18; S13@18-18] Earley Set 19 ahm4: R1$@18-19 R1$: S ::= a A[] . [c=R1:0@18-18; s=a; t=\'a'] ahm1: R0:1@18-19 R0:1: S ::= a . A [c=R0:0@18-18; s=a; t=\'a'] ahm2: R0$@0-19 R0$: S ::= a A . [l=L1@18; c=R1$@18-19] ahm22: R10$@0-19 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-19] ahm0: R0:0@19-19 R0:0: S ::= . a A ahm3: R1:0@19-19 R1:0: S ::= . a A[] ahm5: R2:0@19-19 R2:0: H ::= . S ahm7: R3:0@19-19 R3:0: B ::= . C ahm9: R4:0@19-19 R4:0: D ::= . E ahm11: R5:0@19-19 R5:0: E ::= . F ahm13: R6:0@19-19 R6:0: F ::= . G ahm15: R7:0@19-19 R7:0: C ::= . D ahm17: R8:0@19-19 R8:0: G ::= . H ahm19: R9:0@19-19 R9:0: A ::= . B L1@19 ["S"; L5@19; S5@19-19] L3@19 ["A"; L1@18; S1@18-19] L5@19 ["H"; L17@19; S17@19-19] L7@19 ["B"; L3@19; S19@19-19] L9@19 ["C"; L7@19; S7@19-19] L11@19 ["D"; L9@19; S15@19-19] L13@19 ["E"; L11@19; S9@19-19] L15@19 ["F"; L13@19; S11@19-19] L17@19 ["G"; L15@19; S13@19-19] Earley Set 20 ahm4: R1$@19-20 R1$: S ::= a A[] . [c=R1:0@19-19; s=a; t=\'a'] ahm1: R0:1@19-20 R0:1: S ::= a . A [c=R0:0@19-19; s=a; t=\'a'] ahm2: R0$@0-20 R0$: S ::= a A . [l=L1@19; c=R1$@19-20] ahm22: R10$@0-20 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-20] ahm0: R0:0@20-20 R0:0: S ::= . a A ahm3: R1:0@20-20 R1:0: S ::= . a A[] ahm5: R2:0@20-20 R2:0: H ::= . S ahm7: R3:0@20-20 R3:0: B ::= . C ahm9: R4:0@20-20 R4:0: D ::= . E ahm11: R5:0@20-20 R5:0: E ::= . F ahm13: R6:0@20-20 R6:0: F ::= . G ahm15: R7:0@20-20 R7:0: C ::= . D ahm17: R8:0@20-20 R8:0: G ::= . H ahm19: R9:0@20-20 R9:0: A ::= . B L1@20 ["S"; L5@20; S5@20-20] L3@20 ["A"; L1@19; S1@19-20] L5@20 ["H"; L17@20; S17@20-20] L7@20 ["B"; L3@20; S19@20-20] L9@20 ["C"; L7@20; S7@20-20] L11@20 ["D"; L9@20; S15@20-20] L13@20 ["E"; L11@20; S9@20-20] L15@20 ["F"; L13@20; S11@20-20] L17@20 ["G"; L15@20; S13@20-20] Marpa-R2-2.086000~dfsg/t/gabend.t0000444000000000000000000001465512342464706014723 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test grammar exceptions -- make sure problems actually # are detected. These tests are for problems which are supposed # to abend. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Test::More tests => 7; use Fatal qw(open close); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . join( q{;}, @_ ) . ')'; } ## end sub default_action ## use critic # NOTE: trace_result not used or tested yet. sub test_grammar { my ( $test_name, $grammar_args, $expected_error, $trace_result ) = @_; my $trace; my $memory; my $added_args = {}; if ($trace_result) { $trace = q{}; ## no critic (InputOutput::RequireBriefOpen) open $memory, q{>}, \$trace; $added_args = { trace_file_handle => $memory }; } ## end if ($trace_result) my $eval_ok = eval { my $grammar = Marpa::R2::Grammar->new( $grammar_args, $added_args ); $grammar->precompute(); 1; }; my $eval_error = $EVAL_ERROR; defined $trace_result and close $memory; DETERMINE_TEST_RESULT: { if ($eval_ok) { Test::More::fail("Failed to catch problem: $test_name"); last DETERMINE_TEST_RESULT; } $eval_error =~ s/ ^ Marpa::R2 \s+ exception \s+ at \s+ .* \z //xms; if ( $eval_error eq $expected_error ) { Test::More::pass("Successfully caught problem: $test_name"); last DETERMINE_TEST_RESULT; } my $diag_message = "Failed to find expected message, was expecting:\n"; my $temp; $temp = $expected_error; $temp =~ s/^/=== /xmsg; chomp $temp; $diag_message .= "$temp\n"; $diag_message .= "This was the message actually received:\n"; $temp = $eval_error; $temp =~ s/^/=== /xmsg; chomp $temp; $diag_message .= "$temp\n"; # $diag_message =~ s/^Marpa::R2 \s+ exception \s+ at .* $//xms; Test::More::diag($diag_message); Test::More::fail("Unexpected message: $test_name"); } ## end DETERMINE_TEST_RESULT: return if not defined $trace_result; if ( index( $trace, $trace_result ) < 0 ) { my $diag_message = "Failed to get expected trace result, was expecting:\n"; my $temp; $temp = $trace_result; $temp =~ s/^/=== /xmsg; chomp $temp; $diag_message .= "$temp\n"; $diag_message .= "This were the traces actually received:\n"; $temp = $eval_error; $temp =~ s/^/=== /xmsg; chomp $temp; $diag_message .= "$temp\n"; Test::More::diag($diag_message); Test::More::fail("Unexpected trace: $test_name"); } ## end if ( index( $trace, $trace_result ) < 0 ) else { Test::More::pass("Tracing OK: $test_name"); } return; } ## end sub test_grammar my $counted_nullable_grammar = { rules => [ { lhs => 'S', rhs => ['Seq'], min => 0, }, { lhs => 'Seq', rhs => [qw(A B)], }, { lhs => 'A' }, { lhs => 'B' }, ], start => 'S', }; test_grammar( 'counted nullable', $counted_nullable_grammar, qq{Nullable symbol "Seq" is on rhs of counted rule\n} . qq{Counted nullables confuse Marpa -- please rewrite the grammar\n} ); my $duplicate_rule_grammar = { rules => [ { lhs => 'Top', rhs => ['Dup'] }, { lhs => 'Dup', rhs => ['Item'], }, { lhs => 'Dup', rhs => ['Item'], }, { lhs => 'Item', rhs => ['a'] }, ], start => 'Top', }; test_grammar( 'duplicate rule', $duplicate_rule_grammar, qq{Duplicate rule: Dup -> Item\n} ); my $unique_lhs_grammar = { rules => [ { lhs => 'Top', rhs => ['Dup'] }, { lhs => 'Dup', rhs => ['Item'], min => 0, }, { lhs => 'Dup', rhs => ['Item'], }, { lhs => 'Item', rhs => ['a'] }, ], start => 'Top', }; test_grammar( 'unique_lhs', $unique_lhs_grammar, qq{LHS of sequence rule would not be unique: Dup -> Item\n} ); my $nulling_terminal_grammar = { rules => [ { lhs => 'Top', rhs => ['Bad'] }, { lhs => 'Top', rhs => ['Good'] }, { lhs => 'Bad', rhs => [] }, ], start => 'Top', terminals => ['Good', 'Bad'], }; test_grammar( 'nulling terminal grammar', $nulling_terminal_grammar, <<'END_OF_MESSAGE' Nulling symbol "Bad" is also a terminal A terminal symbol cannot also be a nulling symbol END_OF_MESSAGE ); my $no_start_grammar = { rules => [ { lhs => 'Top', rhs => ['Bad'] }, ], terminals => ['Bad'], }; test_grammar( 'no start symbol', $no_start_grammar, "No start symbol specified in grammar\n" ); my $start_not_lhs_grammar = { rules => [ { lhs => 'Top', rhs => ['Bad'] }, ], terminals => ['Bad'], start => 'Bad', }; test_grammar( 'start symbol not on lhs', $start_not_lhs_grammar, qq{Start symbol "Bad" not on LHS of any rule\n} ); my $unproductive_start_grammar = { rules => [ { lhs => 'Top', rhs => ['Bad'] }, { lhs => 'Bad', rhs => ['Worse'] }, { lhs => 'Worse', rhs => ['Bad'] }, { lhs => 'Top', rhs => ['Good'] }, ], terminals => ['Good'], start => 'Bad', }; test_grammar( 'unproductive start symbol', $unproductive_start_grammar, qq{Unproductive start symbol: "Bad"\n} ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/stuifzand.t0000444000000000000000000000261612342464706015504 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Regressions tests involving the Stuizand interface use 5.010; use strict; use warnings; use Test::More tests => 1; use lib 'inc'; use Marpa::R2::Test; ## no critic (ErrorHandling::RequireCarping); use Marpa::R2; # Regression test of bug found by Andrew Rodland my $g = Marpa::R2::Grammar->new( { actions => "main", start => "start", source => \"start ::= action => act" } ); $g->precompute; my $r = Marpa::R2::Recognizer->new( { grammar => $g } ); my $value_ref = $r->value; my $value = defined $value_ref ? ${$value_ref} : 'No parse'; sub act {123}; Test::More::is( $value, '123', 'Rodland regression test' ); # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/initial_nulls.t0000444000000000000000000001073512342464706016344 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Two rules which start with nullables, and cycle. use 5.010; use strict; use warnings; use Test::More tests => 9; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{-} if $v_count <= 0; my @vals = map { $_ // q{-} } @_; return $_[0] if scalar @vals == 1; return '(' . join( q{;}, @vals ) . ')'; } ## end sub default_action ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/p p p n/], ], [ 'p', ['t'], ], [ 'p', [], ], [ 'n', ['t'], ], [ 'n', ['r2'], ], [ 'r2', [qw/a b c d e x/], ], [ 'a', [] ], [ 'b', [] ], [ 'c', [] ], [ 'd', [] ], [ 'e', [] ], [ 'a', ['t'] ], [ 'b', ['t'] ], [ 'c', ['t'] ], [ 'd', ['t'] ], [ 'e', ['t'] ], [ 'x', ['t'], ], ], terminals => ['t'], default_action => 'main::default_action', } ); $grammar->precompute(); # The count of results without an r2 production, the count # is C(n-1,3), when n>=4, 0 otherwise. # The count of results with an r2 productions is C(n-1,8). # Total results is the sum of the results with an # r2 production and those without. my @expected_count; $expected_count[1] = 2; # 1 w/o r2; 1 with an r2 $expected_count[2] = 11; # 3 w/o r2; 8 with an r2 $expected_count[3] = 31; # 3 w/o r2; 28 with an r2 $expected_count[4] = 57; # 1 w/o r2; 56 with an r2 $expected_count[5] = 70; # 0 w/o r2; 70 with an r2 $expected_count[6] = 56; # 0 w/o r2; 70 with an r2 $expected_count[7] = 28; # 0 w/o r2; 28 with an r2 $expected_count[8] = 8; # 0 w/o r2; 8 with an r2 $expected_count[9] = 1; # 0 w/o r2; 1 with an r2 for my $input_length ( 1 .. 9 ) { my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, max_parses => 100 } ); for ( 1 .. $input_length ) { $recce->read( 't', 't' ); } my $expected = 1; my $parse_count = 0; while ( $expected and my $value_ref = $recce->value() ) { $expected = 0; $parse_count++; my $value = ${$value_ref}; if ($value =~ m{ \A [(] ((t|[-])[;]){3} (t|[-]) [)] \z }xms ) { $expected = 1; } ## end if ( $value =~ m{ ) (}) elsif ( $value =~ m{ \A [(] ((t|[-])[;]){3} [(] ((t|[-])[;]){5} (t|[-]) [)] [)] \z }xms ) { $expected = 1; } ## end elsif ( $value =~ m{ ) (}) $expected &&= $input_length == ( $value =~ tr/t/t/ ); if ( not $expected ) { Test::More::fail( qq{Unexpected value, length=$input_length, "$value"}); } } ## end while ( $expected and my $value_ref = $recce->value() ) if ($expected) { my $expected_count = $expected_count[$input_length]; if ( $parse_count == $expected_count ) { Test::More::pass( qq{Good parse count $parse_count; input length=$input_length} ); } else { Test::More::fail( qq{Bad parse count $parse_count, expected $expected_count; input length=$input_length} ); } } ## end if ($expected) } ## end for my $input_length ( 1 .. 9 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_prefix.t0000444000000000000000000001127512342464707015472 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test of scannerless parsing -- prefix addition use 5.010; use strict; use warnings; use Test::More tests => 30; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $prefix_grammar = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_RULES'), :default ::= action => do_arg0 :start ::= Script Script ::= Calculation* action => do_list Calculation ::= Expression | ('say') Expression Expression ::= Number | ('+') Expression Expression action => do_add Number ~ [\d] + :discard ~ whitespace whitespace ~ [\s]+ # allow comments :discard ~ ~ | ~ '#' ~ '#' ~ * ~ [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] ~ [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] END_OF_RULES } ); sub My_Actions::do_list { my ( $self, @results ) = @_; return +( scalar @results ) . ' results: ' . join q{ }, @results; } sub My_Actions::do_add { shift; return $_[0] + $_[1] } sub My_Actions::do_arg0 { shift; return shift; } sub My_Actions::show_last_expression { my ($self) = @_; my $recce = $self->{recce}; my ( $start, $end ) = $recce->last_completed_range('Expression'); return if not defined $start; my $last_expression = $recce->range_to_string( $start, $end ); return $last_expression; } ## end sub My_Actions::show_last_expression sub my_parser { my ( $grammar, $string ) = @_; my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); my $self = bless { grammar => $grammar, recce => $recce }, 'My_Actions'; my ( $parse_value, $parse_status, $last_expression ); if ( not defined eval { $recce->read( \$string ); 1 } ) { my $abbreviated_error = $EVAL_ERROR; chomp $abbreviated_error; $abbreviated_error =~ s/\n.*//xms; return 'No parse', $abbreviated_error, $self->show_last_expression(); } ## end if ( not defined eval { $recce->read( \$string ); 1 ...}) my $value_ref = $recce->value($self); if ( not defined $value_ref ) { return 'No parse', 'Input read to end but no parse', $self->show_last_expression(); } return [ return ${$value_ref}, 'Parse OK', 'entire input' ]; } ## end sub my_parser my @tests_data = ( [ '+++ 1 2 3 + + 1 2 4', '1 results: 13', 'Parse OK', 'entire input' ], [ 'say + 1 2', '1 results: 3', 'Parse OK', 'entire input' ], [ '+ 1 say 2', 'No parse', 'Error in SLIF parse: No lexemes accepted at line 1, column 5', '1' ], [ '+ 1 2 3 + + 1 2 4', '3 results: 3 3 7', 'Parse OK', 'entire input' ], [ '+++', 'No parse', 'Input read to end but no parse', 'none' ], [ '++1 2++', 'No parse', 'Input read to end but no parse', '+1 2' ], [ '++1 2++3 4++', 'No parse', 'Input read to end but no parse', '+3 4' ], [ '1 + 2 +3 4 + 5 + 6 + 7', 'No parse', 'Input read to end but no parse', '7' ], [ '+12', 'No parse', 'Input read to end but no parse', '12' ], [ '+1234', 'No parse', 'Input read to end but no parse', '1234' ], ); TEST: for my $test_data (@tests_data) { my ($test_string, $expected_value, $expected_result, $expected_last_expression ) = @{$test_data}; my ($actual_value, $actual_result, $actual_last_expression ) = my_parser( $prefix_grammar, $test_string ); $actual_last_expression //= 'none'; Test::More::is( $actual_value, $expected_value, qq{Value of "$test_string"} ); Test::More::is( $actual_result, $expected_result, qq{Result of "$test_string"} ); Test::More::is( $actual_last_expression, $expected_last_expression, qq{Last expression found in "$test_string"} ); } ## end TEST: for my $test_string (@test_strings) # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_leo2.t0000444000000000000000000001372612342464706015040 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # The example from p. 166 of Leo's paper, # augmented to test Leo prediction items. # use 5.010; use strict; use warnings; use Test::More tests => 9; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub main::default_action { shift; return ( join q{}, grep {defined} @_ ); } ## use critic my $grammar = Marpa::R2::Scanless::G->new( { default_action => 'main::default_action', source => \(<<'END_OF_DSL'), :start ::= ::= 'x' | ::= ::= ::= ::= ::= ::= 'x' '/=' ::= 'x' '*=' ::= 'x' '+=' ::= 'x' '-=' ::= 'x' '=' event divide = completed event multiply = completed event subtract = completed event add = completed event plain = completed :discard ~ whitespace whitespace ~ [\s]* END_OF_DSL } ); # Reaches closure do_test($grammar, 'x = x += x -= x *= x /= x', <<'END_OF_HISTORY' plain add plain add plain subtract add multiply plain subtract add divide multiply plain subtract END_OF_HISTORY ); # Reaches closure and continues do_test($grammar, 'x = x += x -= x *= x /= x = x += x -= x *= x /= x', <<'END_OF_HISTORY' plain add plain add plain subtract add multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract END_OF_HISTORY ); # Reaches closure and continues my $test_slr = do_test($grammar, 'x = x += x -= x *= x /= x = x += x -= x *= x /= x = x = x = x = x = x = x = x = x = x = x', <<'END_OF_HISTORY' plain add plain add plain subtract add multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract add divide multiply plain subtract END_OF_HISTORY ); my $show_progress_output = $test_slr->show_progress(); # Marpa::R2::Display # name: SLIF Leo show_progress() example # start-after-line: END_OF_OUTPUT # end-before-line: '^END_OF_OUTPUT$' my $expected_show_progress_output = <<'END_OF_OUTPUT'; F0 @40-41 L2c38-40 expression -> 'x' . F1 x20 @0...38-41 L1c1-L2c40 expression -> assignment . F2 x2 @8,18-41 L1c17-L2c40 assignment -> . F3 x2 @6,16-41 L1c12-L2c40 assignment -> . F4 x2 @2,12-41 L1c3-L2c40 assignment -> . F5 x2 @4,14-41 L1c7-L2c40 assignment -> . F6 x12 @0...38-41 L1c1-L2c40 assignment -> . R7:1 @40-41 L2c38-40 -> 'x' . '/=' expression F7 x2 @10,20-41 L1c22-L2c40 -> 'x' '/=' expression . R8:1 @40-41 L2c38-40 -> 'x' . '*=' expression F8 x2 @8,18-41 L1c17-L2c40 -> 'x' '*=' expression . R9:1 @40-41 L2c38-40 -> 'x' . '+=' expression F9 x2 @4,14-41 L1c7-L2c40 -> 'x' '+=' expression . R10:1 @40-41 L2c38-40 -> 'x' . '-=' expression F10 x2 @6,16-41 L1c12-L2c40 -> 'x' '-=' expression . R11:1 @40-41 L2c38-40 -> 'x' . '=' expression F11 x13 @0...40-41 L1c1-L2c40 -> 'x' '=' expression . F12 @0-41 L1c1-L2c40 :start -> expression . END_OF_OUTPUT # Marpa::R2::Display::End Marpa::R2::Test::is( $show_progress_output, $expected_show_progress_output, "SLIF Leo show_progress() example" ); # Never reaches closure do_test($grammar, 'x = x += x -= x = x += x -= x', <<'END_OF_HISTORY' plain add plain add plain subtract add plain subtract add plain subtract add plain subtract END_OF_HISTORY ); sub do_test { my ( $grammar, $input, $expected_history ) = @_; my $slr = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); my $event_history; my $pos = $slr->read( \$input ); READ: while (1) { my @event_names; for ( my $ix = 0; my $event = $slr->event($ix); $ix++ ) { push @event_names, @{$event}; } $event_history .= join q{ }, sort @event_names; $event_history .= "\n"; last READ if $pos >= length $input; $pos = $slr->resume(); } ## end READ: while (1) my $value_ref = $slr->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; ( my $expected = $input ) =~ s/\s//gxms; Marpa::R2::Test::is( $value, $expected, "Leo SLIF parse of $expected" ); Marpa::R2::Test::is( $event_history, $expected_history, "Event history of $expected" ); return $slr; } ## end sub do_test # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/chaf.t0000444000000000000000000000403712342464706014375 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Regression test for a chaf bug use 5.010; use strict; use warnings; use Test::More tests => 2; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . ( join q{;}, @_ ) . ')'; } ## end sub default_action ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/A B B B C C /] ], [ 'A', [qw/a/] ], [ 'B', [qw/a/] ], [ 'B', [] ], [ 'C', [] ], ], default_action => 'main::default_action', } ); $grammar->set( { terminals => ['a'], } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_rules, <<'EOS', 'Aycock/Horspool Rules' ); 0: S -> A B B B C C 1: A -> a 2: B -> a 3: B -> /* empty !used */ 4: C -> /* empty !used */ EOS my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); $recce->read( 'a', 'a' ); my $value_ref = $recce->value(); my $value = defined $value_ref ? ${$value_ref} : 'undef'; Test::More::is( $value, '(a;;;;;)', 'subp test' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/null_infinite4.t0000444000000000000000000000514612342464707016422 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # A CHAF rule which starts with nullables, and cycle. use 5.010; use strict; use warnings; use Test::More tests => 1; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) our $dash = q{-}; sub rule_n { shift; return 'n(' . ( join q{;}, map { $_ // q{-} } @_ ) . ')'; } sub start_rule { shift; return 'S(' . ( join q{;}, ( map { $_ // q{-} } @_ ) ) . ')'; } sub rule_f { shift; return 'f(' . ( join q{;}, ( map { $_ // q{-} } @_ ) ) . ')'; } ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', infinite_action => 'quiet', rules => [ { lhs => 'S', rhs => [qw/n n n f/], action => 'main::start_rule' }, { lhs => 'n', rhs => ['a'], action => 'main::rule_n' }, { lhs => 'n', rhs => [], action => 'main::dash' }, { lhs => 'f', rhs => ['a'], action => 'main::rule_f' }, { lhs => 'f', rhs => [], action => 'main::dash' }, { lhs => 'f', rhs => ['S'], action => 'main::rule_f' }, ], terminals => [qw(a)], } ); $grammar->precompute(); my @expected = qw{ S(-;-;-;f(A)) S(-;-;-;f(S(n(A);-;-;-))) S(-;-;n(A);-) S(-;n(A);-;-) S(n(A);-;-;-) }; my $input_length = 1; my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, max_parses => 99 } ); for my $token_ix ( 1 .. $input_length ) { $recce->read( 'a', 'A' ); } my $expected = $expected[$input_length]; my @values = (); while ( my $value_ref = $recce->value() ) { push @values, ${$value_ref}; } Marpa::R2::Test::is( ( join "\n", sort @values ), ( join "\n", @expected ), "value for input length $input_length" ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/infinite_plex.t0000444000000000000000000000767012342464706016337 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # A grammar with cycles use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Fatal qw(open close chdir); use Test::More tests => 4; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; sub make_rule { my ( $lhs_symbol_name, $rhs_symbol_name ) = @_; my $action_name = "main::action_$lhs_symbol_name$rhs_symbol_name"; no strict 'refs'; my $closure = *{$action_name}{'CODE'}; use strict; if ( not defined $closure ) { my $action = sub { $lhs_symbol_name . $rhs_symbol_name . '(' . $_[1] . ')' }; no strict 'refs'; *{$action_name} = $action; use strict; } ## end if ( not defined $closure ) return [ $lhs_symbol_name, [$rhs_symbol_name], $action_name ]; } ## end sub make_rule sub make_plex_rules { my ($size) = @_; my @symbol_names = map { chr +( $_ + ord 'A' ) } ( 0 .. $size - 1 ); my @rules; for my $infinite_symbol (@symbol_names) { for my $rhs_symbol (@symbol_names) { push @rules, make_rule( $infinite_symbol, $rhs_symbol ); } push @rules, make_rule( $infinite_symbol, 't' ); push @rules, make_rule( 's', $infinite_symbol ); } ## end for my $infinite_symbol (@symbol_names) return \@rules; } ## end sub make_plex_rules my $plex1_test = [ '1-plex test', [ start => 's', rules => make_plex_rules(1) ], <<'EOS', sA(AA(At(t))) sA(At(t)) EOS <<'EOS', Cycle found involving rule: 0: A -> A EOS ]; my $plex2_test = [ '2-plex test', [ start => 's', rules => make_plex_rules(2) ], <<'EOS', sA(AA(AB(BA(At(t))))) sA(AA(AB(BB(BA(At(t)))))) sA(AA(AB(BB(Bt(t))))) sA(AA(AB(Bt(t)))) sA(AA(At(t))) sA(AB(BA(AA(At(t))))) sA(AB(BA(At(t)))) sA(AB(BB(BA(AA(At(t)))))) sA(AB(BB(BA(At(t))))) sA(AB(BB(Bt(t)))) sA(AB(Bt(t))) sA(At(t)) sB(BA(AA(AB(BB(Bt(t)))))) sB(BA(AA(AB(Bt(t))))) sB(BA(AA(At(t)))) sB(BA(AB(BB(Bt(t))))) sB(BA(AB(Bt(t)))) sB(BA(At(t))) sB(BB(BA(AA(AB(Bt(t)))))) sB(BB(BA(AA(At(t))))) sB(BB(BA(AB(Bt(t))))) sB(BB(BA(At(t)))) sB(BB(Bt(t))) sB(Bt(t)) EOS <<'EOS', Cycle found involving rule: 0: A -> A Cycle found involving rule: 1: A -> B Cycle found involving rule: 4: B -> A Cycle found involving rule: 5: B -> B EOS ]; for my $test_data ( $plex1_test, $plex2_test ) { my ( $test_name, $rules, $expected_values, $expected_trace ) = @{$test_data}; my $trace = q{}; open my $MEMORY, '>', \$trace; my %args = ( @{$rules}, infinite_action => 'warn', trace_file_handle => $MEMORY, ); my $grammar = Marpa::R2::Grammar->new( \%args ); $grammar->precompute(); close $MEMORY; Marpa::R2::Test::is( $trace, $expected_trace, "$test_name trace" ); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, trace_file_handle => \*STDERR } ); $recce->read( 't', 't' ); my @values = (); while ( my $value_ref = $recce->value() ) { push @values, ${$value_ref}; } my $values = join "\n", sort @values; Marpa::R2::Test::is( "$values\n", $expected_values, $test_name ); } ## end for my $test_data ( $plex1_test, $plex2_test ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_numeric.t0000444000000000000000000000545412342464707015641 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test of null ranking use 5.010; use strict; use warnings; use Test::More tests => 10; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . join( q{;}, @_ ) . ')'; } ## end sub default_action ## use critic # Marpa::R2::Display # name: null-ranking adverb example my $high_dsl = <<'END_OF_DSL'; :default ::= action => main::default_action :start ::= S A ::= 'a' A ::= empty empty ::= S ::= A A A A null-ranking => high END_OF_DSL # Marpa::R2::Display::End my $low_dsl = $high_dsl; $low_dsl =~ s/\s+ [=][>] \s+ high \Z/ => low/xms; my %dsl = ( high => \$high_dsl, low => \$low_dsl ); my @maximal = ( q{}, qw[(a;;;) (a;a;;) (a;a;a;) (a;a;a;a)] ); my @minimal = ( q{}, qw[(;;;a) (;;a;a) (;a;a;a) (a;a;a;a)] ); for my $maximal ( 0, 1 ) { my $dsl = $dsl{ $maximal ? 'low' : 'high' }; my $slg = Marpa::R2::Scanless::G->new( { source => $dsl } ); my $slr = Marpa::R2::Scanless::R->new( { grammar => $slg, ranking_method => 'high_rule_only' } ); my $input_length = 4; my $input = 'a' x $input_length; $slr->read( \$input ); for my $i ( 0 .. $input_length ) { my $expected = $maximal ? \@maximal : \@minimal; my $name = $maximal ? 'maximal' : 'minimal'; # Marpa::R2::Display # name: SLIF recognizer series_restart() synopsis $slr->series_restart( { end => $i } ); # Marpa::R2::Display::End # Marpa::R2::Display # name: SLIF recognizer set() synopsis $slr->set( { max_parses => 42 } ); # Marpa::R2::Display::End my $result = $slr->value(); die "No parse" if not defined $result; Test::More::is( ${$result}, $expected->[$i], "$name parse, length=$i" ); } ## end for my $i ( 0 .. $input_length ) } ## end for my $maximal ( 0, 1 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/use.t0000444000000000000000000001025712342464707014272 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use warnings; use strict; use English qw( -no_match_vars ); use Getopt::Long (); use Test::More ( import => [] ); use lib 'pperl'; BEGIN { my $PPI_problem; CHECK_PPI: { if ( not eval { require PPI } ) { $PPI_problem = "PPI not installed: $EVAL_ERROR"; last CHECK_PPI; } if ( not PPI->VERSION(1.206) ) { $PPI_problem = 'PPI 1.206 not installed'; } } ## end CHECK_PPI: if ($PPI_problem) { Test::More::plan skip_all => $PPI_problem; } else { Test::More::plan tests => 1; } } ## end BEGIN use Marpa::R2; use Marpa::R2::Perl; use lib 'inc'; use Marpa::R2::Test; # Run in utility mode? my $utility = 0; die if not Getopt::Long::GetOptions( utility => \$utility ); sub concat { shift @_; return join q{}, map { $_ // '!UNDEF in concat!' } @_; } my %closure_by_action = ( long_use => sub { 'LONG: ' . join q{ }, map { $_ // q{()} } @_[ 1, 3 .. $#_ ]; }, revlong_use => sub { 'REVLONG: ' . join q{ }, map { $_ // q{()} } @_[ 1, 3 .. $#_ ]; }, perl_version_use => sub { 'PERL: ' . join q{ }, map { $_ // q{()} } @_[ 1, 3 .. $#_ ]; }, short_use => sub { 'SHORT: ' . join q{ }, map { $_ // q{()} } @_[ 1, 3 .. $#_ ]; }, argexpr => \&concat, ); my %closure_by_lhs = ( prog => sub { return $_[1] . "\n" }, ary => \&concat, lineseq => sub { shift @_; join "\n", grep { defined and length } @_; }, ); sub gen_closure { my ( $lhs, $rhs, $action ) = @_; my $closure = $closure_by_action{$action} // $closure_by_lhs{$lhs}; return $closure if defined $closure and ref $closure eq 'CODE'; die "lhs=$lhs: $closure is not a closure" if defined $closure; return sub {undef} if scalar @{$rhs} == 0; return sub { $_[1] } if scalar @{$rhs} == 1; return sub { my @args = map { $_ // 'undef' } @_[ 1 .. $#_ ]; return ( join "\n", @args ) . "\n$lhs ::= " . ( join q{ }, map { $_ // q{-} } @{$rhs} ) . q{; }; }; } ## end sub gen_closure my $parser = Marpa::R2::Perl->new( { closures => \&gen_closure } ); my $default_input = <<'END_OF_TEST_DATA'; use v5; use 5; use 5.1; use xyz; use v5 xyz; use 5 xyz; use 5.1 xyz; use xyz v5; use xyz 5; use xyz 5.1; use v5 xyz 5; use 5 xyz 5; use 5.1 xyz 5; use xyz v5 5; use xyz 5 5; use xyz 5.1 5; use v5 xyz 5, 5; use 5 xyz 5, 5; use 5.1 xyz 5, 5; use xyz v5 5, 5; use xyz 5 5, 5; use xyz 5.1 5, 5; use xyz 5.1 @a; END_OF_TEST_DATA my $string; if ($utility) { $string = do { local $RS = undef; }; } else { $string = $default_input; } my $expected = <<'EOS'; PERL: use v5 ; PERL: use 5 ; PERL: use 5.1 ; SHORT: use xyz () ; REVLONG: use v5 xyz () ; REVLONG: use 5 xyz () ; REVLONG: use 5.1 xyz () ; LONG: use xyz v5 () ; LONG: use xyz 5 () ; LONG: use xyz 5.1 () ; REVLONG: use v5 xyz 5 ; REVLONG: use 5 xyz 5 ; REVLONG: use 5.1 xyz 5 ; LONG: use xyz v5 5 ; LONG: use xyz 5 5 ; LONG: use xyz 5.1 5 ; REVLONG: use v5 xyz 5,5 ; REVLONG: use 5 xyz 5,5 ; REVLONG: use 5.1 xyz 5,5 ; LONG: use xyz v5 5,5 ; LONG: use xyz 5 5,5 ; LONG: use xyz 5.1 5,5 ; LONG: use xyz 5.1 @a ; EOS $parser->read( \$string ); my $result_ref = $parser->eval(); my $result = defined $result_ref ? ${$result_ref} : 'no parse'; if ($utility) { say $result or die 'say builtin failed'; } else { Marpa::R2::Test::is( $result, $expected, 'Test of use statements' ); } # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/final_nonnullable.t0000444000000000000000000000776512342464707017172 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Catch the case of a final non-nulling symbol at the end of a rule # which has more than 2 proper nullables # This is to test an untested branch of the CHAF logic. use 5.010; use strict; use warnings; use Test::More tests => 10; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{-} if $v_count <= 0; my @vals = map { $_ // q{-} } @_; return $vals[0] if $v_count == 1; return '(' . join( q{;}, @vals ) . ')'; } ## end sub default_action ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/p p p n/], ], [ 'p', ['a'], ], [ 'p', [], ], [ 'n', ['a'], ], ], terminals => ['a'], default_action => 'main::default_action', } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_rules, <<'END_OF_STRING', 'final nonnulling Rules' ); 0: S -> p p p n 1: p -> a 2: p -> /* empty !used */ 3: n -> a END_OF_STRING Marpa::R2::Test::is( $grammar->show_ahms, <<'END_OF_STRING', 'final nonnulling AHFA' ); AHM 0: postdot = "p" S ::= . p p S[R0:2] AHM 1: postdot = "p" S ::= p . p S[R0:2] AHM 2: postdot = "S[R0:2]" S ::= p p . S[R0:2] AHM 3: completion S ::= p p S[R0:2] . AHM 4: postdot = "p" S ::= . p p[] S[R0:2] AHM 5: postdot = "S[R0:2]" S ::= p p[] . S[R0:2] AHM 6: completion S ::= p p[] S[R0:2] . AHM 7: postdot = "p" S ::= p[] . p S[R0:2] AHM 8: postdot = "S[R0:2]" S ::= p[] p . S[R0:2] AHM 9: completion S ::= p[] p S[R0:2] . AHM 10: postdot = "S[R0:2]" S ::= p[] p[] . S[R0:2] AHM 11: completion S ::= p[] p[] S[R0:2] . AHM 12: postdot = "p" S[R0:2] ::= . p n AHM 13: postdot = "n" S[R0:2] ::= p . n AHM 14: completion S[R0:2] ::= p n . AHM 15: postdot = "n" S[R0:2] ::= p[] . n AHM 16: completion S[R0:2] ::= p[] n . AHM 17: postdot = "a" p ::= . a AHM 18: completion p ::= a . AHM 19: postdot = "a" n ::= . a AHM 20: completion n ::= a . AHM 21: postdot = "S" S['] ::= . S AHM 22: completion S['] ::= S . END_OF_STRING my @expected = map { +{ map { ( $_ => 1 ) } @{$_} } } [q{}], [qw( (-;-;-;a) )], [qw( (a;-;-;a) (-;-;a;a) (-;a;-;a) )], [qw( (a;a;-;a) (-;a;a;a) (a;-;a;a))], [qw( (a;a;a;a) )]; for my $input_length ( 1 .. 4 ) { # Set max at 10 just in case there's an infinite loop. # This is for debugging, after all my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, max_parses => 10 } ); for ( 1 .. $input_length ) { $recce->read( 'a', 'a' ); } while ( my $value_ref = $recce->value() ) { my $value = $value_ref ? ${$value_ref} : 'No parse'; my $expected = $expected[$input_length]; if ( defined $expected->{$value} ) { delete $expected->{$value}; Test::More::pass(qq{Expected value: "$value"}); } else { Test::More::fail(qq{Unexpected value: "$value"}); } } ## end while ( my $value_ref = $recce->value() ) } ## end for my $input_length ( 1 .. 4 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/jirotka.t0000444000000000000000000004027612342464706015144 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # An ambiguous equation use 5.010; use strict; use warnings; use Test::More tests => 7; use lib 'inc'; use Marpa::R2::Test; use Data::Dumper; use English qw( -no_match_vars ); use Fatal qw( close open ); use Marpa::R2; # Regression test for bug originally found and documented # by Tomas Jirotka ## INPUT DATA my $tokens = [ [ 'CREATE', 'Create' ], [ 'METRIC', 'Metric' ], [ 'ID_METRIC', 'm' ], [ 'AS', 'As' ], [ 'SELECT', 'Select' ], [ 'NUMBER', 1 ], [ 'WHERE', 'Where' ], [ 'TRUE', 'True' ], ]; my @terminals = qw/AS BY CREATE FALSE FOR METRIC PF SELECT TRUE WHERE WITH ID_METRIC SEPARATOR NUMBER/; my $grammar = Marpa::R2::Grammar->new( { start => 'Input', action_object => 'Maql_Actions', default_action => 'tisk', default_empty_action => '::undef', terminals => \@terminals, rules => [ { lhs => 'Input', rhs => ['Statement'], min => 1, separator => 'SEPARATOR' }, { lhs => 'Statement', rhs => [qw/CREATE TypeDef/], }, { lhs => 'TypeDef', rhs => [qw/METRIC ID_METRIC AS MetricSelect/], }, { lhs => 'MetricSelect', rhs => [qw/SELECT MetricExpr ByClause Match Filter WithPf/], }, { lhs => 'MetricExpr', rhs => [qw/NUMBER/], }, ############################################################################## { lhs => 'ByClause', rhs => [], }, { lhs => 'ByClause', rhs => [qw/BY/], }, ############################################################################## { lhs => 'Match', rhs => [], }, { lhs => 'Match', rhs => [qw/FOR/], }, ############################################################################# { lhs => 'Filter', rhs => [], }, { lhs => 'Filter', rhs => [qw/WHERE FilterExpr/], }, { lhs => 'FilterExpr', rhs => [qw/TRUE/], }, { lhs => 'FilterExpr', rhs => [qw/FALSE/], }, ############################################################################### { lhs => 'WithPf', rhs => [], }, { lhs => 'WithPf', rhs => [qw/WITH PF/], }, ############################################################################### ], } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_symbols(), <<'END_OF_SYMBOLS', 'Symbols' ); 0: AS, terminal 1: BY, terminal 2: CREATE, terminal 3: FALSE, terminal 4: FOR, terminal 5: METRIC, terminal 6: PF, terminal 7: SELECT, terminal 8: TRUE, terminal 9: WHERE, terminal 10: WITH, terminal 11: ID_METRIC, terminal 12: SEPARATOR, terminal 13: NUMBER, terminal 14: Input 15: Statement 16: TypeDef 17: MetricSelect 18: MetricExpr 19: ByClause 20: Match 21: Filter 22: WithPf 23: FilterExpr END_OF_SYMBOLS Marpa::R2::Test::is( $grammar->show_rules(), <<'END_OF_RULES', 'Rules' ); 0: Input -> Statement+ /* discard_sep */ 1: Statement -> CREATE TypeDef 2: TypeDef -> METRIC ID_METRIC AS MetricSelect 3: MetricSelect -> SELECT MetricExpr ByClause Match Filter WithPf 4: MetricExpr -> NUMBER 5: ByClause -> /* empty !used */ 6: ByClause -> BY 7: Match -> /* empty !used */ 8: Match -> FOR 9: Filter -> /* empty !used */ 10: Filter -> WHERE FilterExpr 11: FilterExpr -> TRUE 12: FilterExpr -> FALSE 13: WithPf -> /* empty !used */ 14: WithPf -> WITH PF END_OF_RULES Marpa::R2::Test::is( $grammar->show_ahms(), <<'END_OF_AHMS', 'AHMs' ); AHM 0: postdot = "Input[Seq]" Input ::= . Input[Seq] AHM 1: completion Input ::= Input[Seq] . AHM 2: postdot = "Input[Seq]" Input ::= . Input[Seq] SEPARATOR AHM 3: postdot = "SEPARATOR" Input ::= Input[Seq] . SEPARATOR AHM 4: completion Input ::= Input[Seq] SEPARATOR . AHM 5: postdot = "Statement" Input[Seq] ::= . Statement AHM 6: completion Input[Seq] ::= Statement . AHM 7: postdot = "Input[Seq]" Input[Seq] ::= . Input[Seq] SEPARATOR Statement AHM 8: postdot = "SEPARATOR" Input[Seq] ::= Input[Seq] . SEPARATOR Statement AHM 9: postdot = "Statement" Input[Seq] ::= Input[Seq] SEPARATOR . Statement AHM 10: completion Input[Seq] ::= Input[Seq] SEPARATOR Statement . AHM 11: postdot = "CREATE" Statement ::= . CREATE TypeDef AHM 12: postdot = "TypeDef" Statement ::= CREATE . TypeDef AHM 13: completion Statement ::= CREATE TypeDef . AHM 14: postdot = "METRIC" TypeDef ::= . METRIC ID_METRIC AS MetricSelect AHM 15: postdot = "ID_METRIC" TypeDef ::= METRIC . ID_METRIC AS MetricSelect AHM 16: postdot = "AS" TypeDef ::= METRIC ID_METRIC . AS MetricSelect AHM 17: postdot = "MetricSelect" TypeDef ::= METRIC ID_METRIC AS . MetricSelect AHM 18: completion TypeDef ::= METRIC ID_METRIC AS MetricSelect . AHM 19: postdot = "SELECT" MetricSelect ::= . SELECT MetricExpr ByClause MetricSelect[R3:3] AHM 20: postdot = "MetricExpr" MetricSelect ::= SELECT . MetricExpr ByClause MetricSelect[R3:3] AHM 21: postdot = "ByClause" MetricSelect ::= SELECT MetricExpr . ByClause MetricSelect[R3:3] AHM 22: postdot = "MetricSelect[R3:3]" MetricSelect ::= SELECT MetricExpr ByClause . MetricSelect[R3:3] AHM 23: completion MetricSelect ::= SELECT MetricExpr ByClause MetricSelect[R3:3] . AHM 24: postdot = "SELECT" MetricSelect ::= . SELECT MetricExpr ByClause Match[] Filter[] WithPf[] AHM 25: postdot = "MetricExpr" MetricSelect ::= SELECT . MetricExpr ByClause Match[] Filter[] WithPf[] AHM 26: postdot = "ByClause" MetricSelect ::= SELECT MetricExpr . ByClause Match[] Filter[] WithPf[] AHM 27: completion MetricSelect ::= SELECT MetricExpr ByClause Match[] Filter[] WithPf[] . AHM 28: postdot = "SELECT" MetricSelect ::= . SELECT MetricExpr ByClause[] MetricSelect[R3:3] AHM 29: postdot = "MetricExpr" MetricSelect ::= SELECT . MetricExpr ByClause[] MetricSelect[R3:3] AHM 30: postdot = "MetricSelect[R3:3]" MetricSelect ::= SELECT MetricExpr ByClause[] . MetricSelect[R3:3] AHM 31: completion MetricSelect ::= SELECT MetricExpr ByClause[] MetricSelect[R3:3] . AHM 32: postdot = "SELECT" MetricSelect ::= . SELECT MetricExpr ByClause[] Match[] Filter[] WithPf[] AHM 33: postdot = "MetricExpr" MetricSelect ::= SELECT . MetricExpr ByClause[] Match[] Filter[] WithPf[] AHM 34: completion MetricSelect ::= SELECT MetricExpr ByClause[] Match[] Filter[] WithPf[] . AHM 35: postdot = "Match" MetricSelect[R3:3] ::= . Match MetricSelect[R3:4] AHM 36: postdot = "MetricSelect[R3:4]" MetricSelect[R3:3] ::= Match . MetricSelect[R3:4] AHM 37: completion MetricSelect[R3:3] ::= Match MetricSelect[R3:4] . AHM 38: postdot = "Match" MetricSelect[R3:3] ::= . Match Filter[] WithPf[] AHM 39: completion MetricSelect[R3:3] ::= Match Filter[] WithPf[] . AHM 40: postdot = "MetricSelect[R3:4]" MetricSelect[R3:3] ::= Match[] . MetricSelect[R3:4] AHM 41: completion MetricSelect[R3:3] ::= Match[] MetricSelect[R3:4] . AHM 42: postdot = "Filter" MetricSelect[R3:4] ::= . Filter WithPf AHM 43: postdot = "WithPf" MetricSelect[R3:4] ::= Filter . WithPf AHM 44: completion MetricSelect[R3:4] ::= Filter WithPf . AHM 45: postdot = "Filter" MetricSelect[R3:4] ::= . Filter WithPf[] AHM 46: completion MetricSelect[R3:4] ::= Filter WithPf[] . AHM 47: postdot = "WithPf" MetricSelect[R3:4] ::= Filter[] . WithPf AHM 48: completion MetricSelect[R3:4] ::= Filter[] WithPf . AHM 49: postdot = "NUMBER" MetricExpr ::= . NUMBER AHM 50: completion MetricExpr ::= NUMBER . AHM 51: postdot = "BY" ByClause ::= . BY AHM 52: completion ByClause ::= BY . AHM 53: postdot = "FOR" Match ::= . FOR AHM 54: completion Match ::= FOR . AHM 55: postdot = "WHERE" Filter ::= . WHERE FilterExpr AHM 56: postdot = "FilterExpr" Filter ::= WHERE . FilterExpr AHM 57: completion Filter ::= WHERE FilterExpr . AHM 58: postdot = "TRUE" FilterExpr ::= . TRUE AHM 59: completion FilterExpr ::= TRUE . AHM 60: postdot = "FALSE" FilterExpr ::= . FALSE AHM 61: completion FilterExpr ::= FALSE . AHM 62: postdot = "WITH" WithPf ::= . WITH PF AHM 63: postdot = "PF" WithPf ::= WITH . PF AHM 64: completion WithPf ::= WITH PF . AHM 65: postdot = "Input" Input['] ::= . Input AHM 66: completion Input['] ::= Input . END_OF_AHMS my $recog = Marpa::R2::Recognizer->new( { grammar => $grammar } ); for my $token ( @{$tokens} ) { $recog->read( @{$token} ); } my @result = $recog->value(); Marpa::R2::Test::is( $recog->show_earley_sets(), <<'END_OF_EARLEY_SETS', 'Earley Sets' ); Last Completed: 8; Furthest: 8 Earley Set 0 ahm65: R23:0@0-0 R23:0: Input['] ::= . Input ahm0: R0:0@0-0 R0:0: Input ::= . Input[Seq] ahm2: R1:0@0-0 R1:0: Input ::= . Input[Seq] SEPARATOR ahm5: R2:0@0-0 R2:0: Input[Seq] ::= . Statement ahm7: R3:0@0-0 R3:0: Input[Seq] ::= . Input[Seq] SEPARATOR Statement ahm11: R4:0@0-0 R4:0: Statement ::= . CREATE TypeDef Earley Set 1 ahm12: R4:1@0-1 R4:1: Statement ::= CREATE . TypeDef [c=R4:0@0-0; s=CREATE; t=\'Create'] ahm14: R5:0@1-1 R5:0: TypeDef ::= . METRIC ID_METRIC AS MetricSelect Earley Set 2 ahm15: R5:1@1-2 R5:1: TypeDef ::= METRIC . ID_METRIC AS MetricSelect [c=R5:0@1-1; s=METRIC; t=\'Metric'] Earley Set 3 ahm16: R5:2@1-3 R5:2: TypeDef ::= METRIC ID_METRIC . AS MetricSelect [c=R5:1@1-2; s=ID_METRIC; t=\'m'] Earley Set 4 ahm17: R5:3@1-4 R5:3: TypeDef ::= METRIC ID_METRIC AS . MetricSelect [c=R5:2@1-3; s=AS; t=\'As'] ahm19: R6:0@4-4 R6:0: MetricSelect ::= . SELECT MetricExpr ByClause MetricSelect[R3:3] ahm24: R7:0@4-4 R7:0: MetricSelect ::= . SELECT MetricExpr ByClause Match[] Filter[] WithPf[] ahm28: R8:0@4-4 R8:0: MetricSelect ::= . SELECT MetricExpr ByClause[] MetricSelect[R3:3] ahm32: R9:0@4-4 R9:0: MetricSelect ::= . SELECT MetricExpr ByClause[] Match[] Filter[] WithPf[] Earley Set 5 ahm33: R9:1@4-5 R9:1: MetricSelect ::= SELECT . MetricExpr ByClause[] Match[] Filter[] WithPf[] [c=R9:0@4-4; s=SELECT; t=\'Select'] ahm29: R8:1@4-5 R8:1: MetricSelect ::= SELECT . MetricExpr ByClause[] MetricSelect[R3:3] [c=R8:0@4-4; s=SELECT; t=\'Select'] ahm25: R7:1@4-5 R7:1: MetricSelect ::= SELECT . MetricExpr ByClause Match[] Filter[] WithPf[] [c=R7:0@4-4; s=SELECT; t=\'Select'] ahm20: R6:1@4-5 R6:1: MetricSelect ::= SELECT . MetricExpr ByClause MetricSelect[R3:3] [c=R6:0@4-4; s=SELECT; t=\'Select'] ahm49: R16:0@5-5 R16:0: MetricExpr ::= . NUMBER Earley Set 6 ahm50: R16$@5-6 R16$: MetricExpr ::= NUMBER . [c=R16:0@5-5; s=NUMBER; t=\1] ahm21: R6:2@4-6 R6:2: MetricSelect ::= SELECT MetricExpr . ByClause MetricSelect[R3:3] [p=R6:1@4-5; c=R16$@5-6] ahm26: R7:2@4-6 R7:2: MetricSelect ::= SELECT MetricExpr . ByClause Match[] Filter[] WithPf[] [p=R7:1@4-5; c=R16$@5-6] ahm30: R8:3@4-6 R8:3: MetricSelect ::= SELECT MetricExpr ByClause[] . MetricSelect[R3:3] [p=R8:1@4-5; c=R16$@5-6] ahm34: R9$@4-6 R9$: MetricSelect ::= SELECT MetricExpr ByClause[] Match[] Filter[] WithPf[] . [p=R9:1@4-5; c=R16$@5-6] ahm18: R5$@1-6 R5$: TypeDef ::= METRIC ID_METRIC AS MetricSelect . [p=R5:3@1-4; c=R9$@4-6] ahm13: R4$@0-6 R4$: Statement ::= CREATE TypeDef . [p=R4:1@0-1; c=R5$@1-6] ahm6: R2$@0-6 R2$: Input[Seq] ::= Statement . [p=R2:0@0-0; c=R4$@0-6] ahm8: R3:1@0-6 R3:1: Input[Seq] ::= Input[Seq] . SEPARATOR Statement [p=R3:0@0-0; c=R2$@0-6] ahm3: R1:1@0-6 R1:1: Input ::= Input[Seq] . SEPARATOR [p=R1:0@0-0; c=R2$@0-6] ahm1: R0$@0-6 R0$: Input ::= Input[Seq] . [p=R0:0@0-0; c=R2$@0-6] ahm66: R23$@0-6 R23$: Input['] ::= Input . [p=R23:0@0-0; c=R0$@0-6] ahm51: R17:0@6-6 R17:0: ByClause ::= . BY ahm35: R10:0@6-6 R10:0: MetricSelect[R3:3] ::= . Match MetricSelect[R3:4] ahm38: R11:0@6-6 R11:0: MetricSelect[R3:3] ::= . Match Filter[] WithPf[] ahm40: R12:1@6-6 R12:1: MetricSelect[R3:3] ::= Match[] . MetricSelect[R3:4] ahm42: R13:0@6-6 R13:0: MetricSelect[R3:4] ::= . Filter WithPf ahm45: R14:0@6-6 R14:0: MetricSelect[R3:4] ::= . Filter WithPf[] ahm47: R15:1@6-6 R15:1: MetricSelect[R3:4] ::= Filter[] . WithPf ahm53: R18:0@6-6 R18:0: Match ::= . FOR ahm55: R19:0@6-6 R19:0: Filter ::= . WHERE FilterExpr ahm62: R22:0@6-6 R22:0: WithPf ::= . WITH PF Earley Set 7 ahm56: R19:1@6-7 R19:1: Filter ::= WHERE . FilterExpr [c=R19:0@6-6; s=WHERE; t=\'Where'] ahm58: R20:0@7-7 R20:0: FilterExpr ::= . TRUE ahm60: R21:0@7-7 R21:0: FilterExpr ::= . FALSE Earley Set 8 ahm59: R20$@7-8 R20$: FilterExpr ::= TRUE . [c=R20:0@7-7; s=TRUE; t=\'True'] ahm57: R19$@6-8 R19$: Filter ::= WHERE FilterExpr . [p=R19:1@6-7; c=R20$@7-8] ahm46: R14$@6-8 R14$: MetricSelect[R3:4] ::= Filter WithPf[] . [p=R14:0@6-6; c=R19$@6-8] ahm43: R13:1@6-8 R13:1: MetricSelect[R3:4] ::= Filter . WithPf [p=R13:0@6-6; c=R19$@6-8] ahm41: R12$@6-8 R12$: MetricSelect[R3:3] ::= Match[] MetricSelect[R3:4] . [p=R12:1@6-6; c=R14$@6-8] ahm31: R8$@4-8 R8$: MetricSelect ::= SELECT MetricExpr ByClause[] MetricSelect[R3:3] . [p=R8:3@4-6; c=R12$@6-8] ahm18: R5$@1-8 R5$: TypeDef ::= METRIC ID_METRIC AS MetricSelect . [p=R5:3@1-4; c=R8$@4-8] ahm13: R4$@0-8 R4$: Statement ::= CREATE TypeDef . [p=R4:1@0-1; c=R5$@1-8] ahm6: R2$@0-8 R2$: Input[Seq] ::= Statement . [p=R2:0@0-0; c=R4$@0-8] ahm8: R3:1@0-8 R3:1: Input[Seq] ::= Input[Seq] . SEPARATOR Statement [p=R3:0@0-0; c=R2$@0-8] ahm3: R1:1@0-8 R1:1: Input ::= Input[Seq] . SEPARATOR [p=R1:0@0-0; c=R2$@0-8] ahm1: R0$@0-8 R0$: Input ::= Input[Seq] . [p=R0:0@0-0; c=R2$@0-8] ahm66: R23$@0-8 R23$: Input['] ::= Input . [p=R23:0@0-0; c=R0$@0-8] ahm62: R22:0@8-8 R22:0: WithPf ::= . WITH PF END_OF_EARLEY_SETS Marpa::R2::Test::is( $recog->show_and_nodes(), <<'END_OF_AND_NODES', 'And Nodes' ); And-node #0: R4:1@0-1S2@0 And-node #19: R0:1@0-8C2@0 And-node #18: R2:1@0-8C4@0 And-node #17: R4:2@0-8C5@1 And-node #20: R23:1@0-8C0@0 And-node #1: R5:1@1-2S5@1 And-node #2: R5:2@1-3S11@2 And-node #3: R5:3@1-4S0@3 And-node #16: R5:4@1-8C8@4 And-node #4: R8:1@4-5S7@4 And-node #6: R8:2@4-6C16@5 And-node #7: R8:3@4-6S20@6 And-node #15: R8:4@4-8C12@6 And-node #5: R16:1@5-6S13@5 And-node #8: R12:1@6-6S22@6 And-node #9: R19:1@6-7S9@6 And-node #14: R12:2@6-8C14@6 And-node #12: R14:1@6-8C19@6 And-node #13: R14:2@6-8S26@8 And-node #11: R19:2@6-8C20@7 And-node #10: R20:1@7-8S8@7 END_OF_AND_NODES Marpa::R2::Test::is( $recog->show_or_nodes(), <<'END_OF_OR_NODES', 'Or Nodes' ); R4:1@0-1 R0:1@0-8 R2:1@0-8 R4:2@0-8 R23:1@0-8 R5:1@1-2 R5:2@1-3 R5:3@1-4 R5:4@1-8 R8:1@4-5 R8:2@4-6 R8:3@4-6 R8:4@4-8 R16:1@5-6 R12:1@6-6 R19:1@6-7 R12:2@6-8 R14:1@6-8 R14:2@6-8 R19:2@6-8 R20:1@7-8 END_OF_OR_NODES Marpa::R2::Test::is( Dumper( \@result ), <<'END_OF_STRING', 'Result' ); $VAR1 = [ \[ [ 'Create', [ 'Metric', 'm', 'As', [ 'Select', [ 1 ], undef, undef, [ 'Where', [ 'True' ] ], undef ] ] ] ] ]; END_OF_STRING ############################################################################# package Maql_Actions; sub new { } sub tisk { shift; return \@_; } Marpa-R2-2.086000~dfsg/t/sl_action2.t0000444000000000000000000000600112342464706015522 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test of the actions, focusing on the various types -- # CODE, ref to scalar/hash/array, etc. use 5.010; use strict; use warnings; use Test::More tests => 2; use English qw( -no_match_vars ); use Fatal qw( open close ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $side_effect = 0; no warnings 'once'; $My_Actions::hash_ref = {'a hash ref' => 1}; $My_Actions::array_ref = ['an array ref']; $My_Actions::array_ref2 = ['array ref 2']; $My_Actions::scalar_ref = \8675309; $My_Actions::scalar = 42; $My_Actions::scalar2 = 'scalar2'; $My_Actions::code_ref = sub { return 'code ref' }; $My_Actions::code_ref2 = sub { return 'code ref 2' }; $My_Actions::code_ref_ref = \(sub { return 'code ref ref' }); sub My_Actions::scalar2 { return ( 'should not see me', 'shadow of scalar 2' ) }; sub My_Actions::array_ref2 { return 'shadow of array_ref2' }; sub My_Actions::code_ref2 { return 'shadow of code_ref2' }; use warnings; sub My_Actions::code { return 'code' }; sub My_Actions::new { $side_effect = 42; } my $grammar = Marpa::R2::Scanless::G->new( { source => \<<'END_OF_SOURCE', :default ::= action => ::array :start ::= S S ::= ::= 'a' action => array_ref ::= 'a' action => hash_ref ::= 'a' action => scalar_ref ::= 'a' action => code_ref ::= 'a' action => code_ref_ref ::= 'a' action => code ::= 'a' action => scalar ::= 'a' action => scalar2 ::= 'a' action => array_ref2 ::= 'a' action => code_ref2 END_OF_SOURCE }); sub do_parse { my $slr = Marpa::R2::Scanless::R->new( { grammar => $grammar, semantics_package => 'My_Actions', } ); $slr->read( \'aaaaaaaaaa' ); return $slr->value(); } ## end sub do_parse my $value_ref; $value_ref = do_parse(); my $expected = \[ [ 'an array ref' ], { 'a hash ref' => 1 }, \8675309, $My_Actions::code_ref, $My_Actions::code_ref_ref, 'code', 42, 'shadow of scalar 2', 'shadow of array_ref2', 'shadow of code_ref2' ]; Test::More::is_deeply($value_ref, $expected, 'Constant actions'); Test::More::is($side_effect, 42, 'semantics_package constructor'); # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_gia_err.t0000444000000000000000000002363012342464707015603 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Tests that include a grammar, an input, and an error message # or an AST, but no semantics. # # Uses include tests of parsing of the SLIF DSL itself. use 5.010; use strict; use warnings; use Test::More tests => 36; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; use Data::Dumper; our $DEBUG = 0; my @tests_data = (); my $zero_grammar = \(<<'END_OF_SOURCE'); :default ::= action => ::array quartet ::= a a a a a ~ 'a' END_OF_SOURCE push @tests_data, [ $zero_grammar, 'aaaa', [qw(a a a a)], 'Parse OK', 'No start statement' ]; my $colon1_grammar = \(<<'END_OF_SOURCE'); :default ::= action => ::array :start ::= quartet quartet ::= a a a a a ~ 'a' END_OF_SOURCE push @tests_data, [ $colon1_grammar, 'aaaa', [qw(a a a a)], 'Parse OK', 'Colon start statement first' ]; my $colon2_grammar = \(<<'END_OF_SOURCE'); :default ::= action => ::array quartet ::= a a a a :start ::= quartet a ~ 'a' END_OF_SOURCE push @tests_data, [ $colon2_grammar, 'aaaa', [qw(a a a a)], 'Parse OK', 'Colon start statement second' ]; my $english1_grammar = \(<<'END_OF_SOURCE'); :default ::= action => ::array start symbol is quartet quartet ::= a a a a a ~ 'a' END_OF_SOURCE push @tests_data, [ $english1_grammar, 'aaaa', [qw(a a a a)], 'Parse OK', 'English start statement first' ]; my $english2_grammar = \(<<'END_OF_SOURCE'); :default ::= action => ::array quartet ::= a a a a start symbol is quartet a ~ 'a' END_OF_SOURCE push @tests_data, [ $english2_grammar, 'aaaa', 'SLIF grammar failed', <<'END_OF_MESSAGE', Parse of BNF/Scanless source is ambiguous Length of symbol "statement" at line 2, column 13 is ambiguous Choices start with: quartet ::= a a a a Choice 1, length=20, ends at line 2, column 32 Choice 1: quartet ::= a a a a Choice 2, length=52, ends at line 3, column 31 Choice 2: quartet ::= a a a a\n start symbol is quarte END_OF_MESSAGE 'English start statement second' ]; my $invalid_syntax_grammar = \(<<'END_OF_SOURCE'); quartet$ ::= a b c d e f END_OF_SOURCE push @tests_data, [ $invalid_syntax_grammar, 'n/a', 'SLIF grammar failed', <<'END_OF_MESSAGE', Parse of BNF/Scanless source failed Error in SLIF parse: No lexeme found at line 1, column 12 * String before error: quartet * The error was at line 1, column 12, and at character 0x0024 '$', ... * here: $ ::= a b c d e f\n END_OF_MESSAGE 'Grammar with syntax error' ]; # test <>-wrapping of SLIF symbol names containing spaces my $non_unique_sequence_grammar = \(<<'END_OF_SOURCE'); ::= item* proper => 1 ::= END_OF_SOURCE push @tests_data, [ $non_unique_sequence_grammar, 'n/a', 'SLIF grammar failed', <<'END_OF_MESSAGE', LHS of sequence rule would not be unique: -> END_OF_MESSAGE 'Grammar with non-unique LHS sequence symbols' ]; ##### my $explicit_grammar1 = \(<<'END_OF_SOURCE'); :default ::= action => ::array quartet ::= a a a a; start symbol is quartet a ~ 'a' END_OF_SOURCE push @tests_data, [ $explicit_grammar1, 'aaaa', [qw(a a a a)], 'Parse OK', 'Explicit English start statement second' ]; ##### { # Marpa::R2::Display # name: statements separted by semicolon # start-after-line: END_OF_SOURCE # end-before-line: '^END_OF_SOURCE$' my $source = \(<<'END_OF_SOURCE'); :default ::= action => ::array quartet ::= a a a a; inaccessible is warn by default a ~ 'a' END_OF_SOURCE # Marpa::R2::Display::End push @tests_data, [ $source, 'aaaa', [qw(a a a a)], 'Parse OK', 'Explicit inaccessible is warn statement second, using semi-colon' ]; } ### { # Marpa::R2::Display # name: statements grouped in curly braces # start-after-line: END_OF_SOURCE # end-before-line: '^END_OF_SOURCE$' my $source = \(<<'END_OF_SOURCE'); { :default ::= action => ::array quartet ::= a a a a } inaccessible is warn by default a ~ 'a' END_OF_SOURCE # Marpa::R2::Display::End push @tests_data, [ $source, 'aaaa', [qw(a a a a)], 'Parse OK', 'Explicit inaccessible is warn statement second, using grouping' ]; } ##### my $explicit_grammar2 = \(<<'END_OF_SOURCE'); :default ::= action => ::array octet ::= a a a a start symbol octet a ~ 'a' start ~ 'a' symbol ~ 'a' is ~ 'a' octet ::= a END_OF_SOURCE push @tests_data, [ $explicit_grammar2, 'aaaaaaaa', [qw(a a a a a a a), ['a']], 'Parse OK', 'Long quartet; no start statement' ]; ##### # test null statements my $disambig_grammar = \(<<'END_OF_SOURCE'); ;:default ::= action => ::array octet ::= a a a a ;a ~ 'a';;;;; END_OF_SOURCE push @tests_data, [ $disambig_grammar, 'aaaa', [qw(a a a a)], 'Parse OK', 'Grammar with null statements' ]; ##### # test grouped statements my $grouping_grammar = \(<<'END_OF_SOURCE'); ;:default ::= action => ::array {quartet ::= a b c d }; a ~ 'a' { b ~ 'b' c~'c' } { d ~ 'd'; }; { {;} } END_OF_SOURCE push @tests_data, [ $grouping_grammar, 'abcd', [qw(a b c d)], 'Parse OK', 'Grammar with grouped statements' ]; ##### # test null adverbs { my $grammar = \(<<'END_OF_SOURCE'); :default ::= ,action => ::array, quartet ::= a b c d , a ~ 'a' { b ~ 'b' c~'c' } d ~ 'd', END_OF_SOURCE push @tests_data, [ $grammar, 'abcd', [qw(a b c d)], 'Parse OK', 'Grammar with null adverbs' ]; } ##### # test null adverbs { my $grammar = \(<<'END_OF_SOURCE'); :default ::= ,action => ::array, quartet ::= a b c d e f { a ~ 'a' { b ~ 'b' { c~'c' {; d~'d' {e~'e'}} }} f ~ 'f' } END_OF_SOURCE push @tests_data, [ $grammar, 'abcdef', [qw(a b c d e f)], 'Parse OK', 'Grammar with nested statement groups' ]; } ##### # test discarding of spaces in array descriptor actions { my $grammar = \(<<'END_OF_SOURCE'); :default ::= action => [lhs, value] lexeme default = action => [ lhs, value ] s ::= a a ~ '42' END_OF_SOURCE push @tests_data, [ $grammar, '42', [ 1, [ 2, '42' ] ], 'Parse OK', 'Grammar with spaces in array descriptor actions' ]; } ##### if (1) { my $grammar = \(<<'END_OF_SOURCE'); :default ::= action => [ lhs, value] lexeme default = action => [lhs, value ] s ::= a a ~ '42' END_OF_SOURCE push @tests_data, [ $grammar, '42', [ 1, [ 2, '42' ] ], 'Parse OK', 'Grammar with spaces in array descriptor actions' ]; } if (1) { my $grammar = \(<<'END_OF_SOURCE'); :default ::= action => [ name, value] lexeme default = action => [name, value ] :start ::= start start ~ 'X' :discard ~ [^[:print:]] END_OF_SOURCE push @tests_data, [ $grammar, 'X', [ qw(start X) ], 'Parse OK', 'Bug found by Jean-Damien Durand' ]; } TEST: for my $test_data (@tests_data) { my ( $source, $input, $expected_value, $expected_result, $test_name ) = @{$test_data}; my ( $actual_value, $actual_result ); PROCESSING: { my $grammar; if (not defined eval { $grammar = Marpa::R2::Scanless::G->new( { source => $source } ); 1; } ) { say $EVAL_ERROR if $DEBUG; my $abbreviated_error = $EVAL_ERROR; chomp $abbreviated_error; $abbreviated_error =~ s/^ Marpa[:][:]R2 \s+ exception \s+ at \s+ .* \z//xms; $actual_value = 'SLIF grammar failed'; $actual_result = $abbreviated_error; last PROCESSING; } ## end if ( not defined eval { $grammar = Marpa::R2::Scanless::G...}) my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); if ( not defined eval { $recce->read( \$input ); 1 } ) { say $EVAL_ERROR if $DEBUG; my $abbreviated_error = $EVAL_ERROR; chomp $abbreviated_error; $actual_value = 'No parse'; $actual_result = $abbreviated_error; last PROCESSING; } ## end if ( not defined eval { $recce->read( \$input ); 1 }) my $value_ref = $recce->value(); if ( not defined $value_ref ) { $actual_value = 'No parse'; $actual_result = 'Input read to end but no parse'; last PROCESSING; } $actual_value = ${$value_ref}; $actual_result = 'Parse OK'; last PROCESSING; } ## end PROCESSING: Marpa::R2::Test::is( Data::Dumper::Dumper( \$actual_value ), Data::Dumper::Dumper( \$expected_value ), qq{Value of $test_name} ); Marpa::R2::Test::is( $actual_result, $expected_result, qq{Result of $test_name} ); } ## end for my $test_data (@tests_data) # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/ah_numeric.t0000444000000000000000000000541312342464707015606 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # the example grammar in Aycock/Horspool "Practical Earley Parsing", # _The Computer Journal_, Vol. 45, No. 6, pp. 620-630, # in its "NNF" form use 5.010; use strict; use warnings; use Test::More tests => 10; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . join( q{;}, @_ ) . ')'; } ## end sub default_action ## use critic sub gen_grammar { my ($null_ranking) = @_; my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ { lhs => 'S', rhs => [qw/A A A A/], null_ranking => $null_ranking }, [ 'A', [qw/a/] ], ['A'], ], default_action => 'main::default_action', } ); $grammar->set( { terminals => ['a'], } ); $grammar->precompute(); return $grammar; } ## end sub gen_grammar my @maximal = ( q{}, qw[(a;;;) (a;a;;) (a;a;a;) (a;a;a;a)] ); my @minimal = ( q{}, qw[(;;;a) (;;a;a) (;a;a;a) (a;a;a;a)] ); for my $maximal ( 0, 1 ) { my $grammar = gen_grammar( $maximal ? 'low' : 'high' ); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, ranking_method => 'high_rule_only' } ); my $input_length = 4; for ( 1 .. $input_length ) { $recce->read( 'a', 'a' ); } for my $i ( 0 .. $input_length ) { my $expected = $maximal ? \@maximal : \@minimal; my $name = $maximal ? 'maximal' : 'minimal'; $recce->reset_evaluation(); $recce->set( { end => $i, } ); my $result = $recce->value(); Test::More::is( ${$result}, $expected->[$i], "$name parse, length=$i" ); } ## end for my $i ( 0 .. $input_length ) } ## end for my $maximal ( 0, 1 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/leo.t0000444000000000000000000001053212342464706014250 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # The example from p. 168-169 of Leo's paper. # # Make sure I have a CHAF example! # use 5.010; use strict; use warnings; use Test::More tests => 17; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub generate_action { my ($lhs) = @_; return sub { shift; my $v_count = scalar @_; return q{-} if $v_count <= 0; my @vals = map { $_ // q{-} } @_; return $lhs . '(' . ( join q{;}, @vals ) . ')'; } } ## end sub generate_action my $C_action = generate_action('C'); my $S_action = generate_action('S'); my $default_action = generate_action(q{?}); ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/a S/], 'S_action', ], [ 'S', [qw/C/], 'S_action', ], [ 'C', [qw(a C b)], 'C_action', ], [ 'C', [], ], ], terminals => [qw(a b)], default_action => 'default_action', } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_symbols(), <<'END_OF_STRING', 'Leo168 Symbols' ); 0: a, terminal 1: b, terminal 2: S 3: C END_OF_STRING Marpa::R2::Test::is( $grammar->show_rules, <<'END_OF_STRING', 'Leo168 Rules' ); 0: S -> a S 1: S -> C 2: C -> a C b 3: C -> /* empty !used */ END_OF_STRING Marpa::R2::Test::is( $grammar->show_ahms, <<'END_OF_STRING', 'Leo168 AHMs' ); AHM 0: postdot = "a" S ::= . a S AHM 1: postdot = "S" S ::= a . S AHM 2: completion S ::= a S . AHM 3: postdot = "a" S ::= . a S[] AHM 4: completion S ::= a S[] . AHM 5: postdot = "C" S ::= . C AHM 6: completion S ::= C . AHM 7: postdot = "a" C ::= . a C b AHM 8: postdot = "C" C ::= a . C b AHM 9: postdot = "b" C ::= a C . b AHM 10: completion C ::= a C b . AHM 11: postdot = "a" C ::= . a C[] b AHM 12: postdot = "b" C ::= a C[] . b AHM 13: completion C ::= a C[] b . AHM 14: postdot = "S" S['] ::= . S AHM 15: completion S['] ::= S . END_OF_STRING my %expected = ( 'a' => q{S(a;-)}, 'ab' => q{S(C(a;-;b))}, 'aa' => q{S(a;S(a;-))}, 'aab' => q{S(a;S(C(a;-;b)))}, 'aabb' => q{S(C(a;C(a;-;b);b))}, 'aaa' => q{S(a;S(a;S(a;-)))}, 'aaab' => q{S(a;S(a;S(C(a;-;b))))}, 'aaabb' => q{S(a;S(C(a;C(a;-;b);b)))}, 'aaabbb' => q{S(C(a;C(a;C(a;-;b);b);b))}, 'aaaa' => q{S(a;S(a;S(a;S(a;-))))}, 'aaaab' => q{S(a;S(a;S(a;S(C(a;-;b)))))}, 'aaaabb' => q{S(a;S(a;S(C(a;C(a;-;b);b))))}, 'aaaabbb' => q{S(a;S(C(a;C(a;C(a;-;b);b);b)))}, 'aaaabbbb' => q{S(C(a;C(a;C(a;C(a;-;b);b);b);b))}, ); for my $a_length ( 1 .. 4 ) { for my $b_length ( 0 .. $a_length ) { my $string = ( 'a' x $a_length ) . ( 'b' x $b_length ); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, closures => { 'C_action' => $C_action, 'S_action' => $S_action, 'default_action' => $default_action, } } ); for (1 .. $a_length ) { $recce->read( 'a', 'a' ); } for (1 .. $b_length ) { $recce->read( 'b', 'b' ); } my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; Marpa::R2::Test::is( $value, $expected{$string}, "Parse of $string" ); } ## end for my $b_length ( 0 .. $a_length ) } ## end for my $a_length ( 1 .. 4 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_json_ast.t0000555000000000000000000002424312342464706016016 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test using a JSON parser # Inspired by a parser written by Peter Stuifzand use 5.010; use strict; use warnings; use Test::More tests => 15; ## no critic (ErrorHandling::RequireCarping); use Marpa::R2; my $p = MarpaX::JSON->new; my $data = $p->parse_json(q${"test":"1"}$); is($data->{test}, 1); { my $test = q${"test":[1,2,3]}$; $data = $p->parse_json(q${"test":[1,2,3]}$); is_deeply( $data->{test}, [ 1, 2, 3 ], $test ); } $data = $p->parse_json(q${"test":true}$); is($data->{test}, 1); $data = $p->parse_json(q${"test":false}$); is($data->{test}, ''); $data = $p->parse_json(q${"test":null}$); is($data->{test}, undef); $data = $p->parse_json(q${"test":null, "test2":"hello world"}$); is($data->{test}, undef); is($data->{test2}, "hello world"); $data = $p->parse_json(q${"test":"1.25"}$); is($data->{test}, '1.25', '1.25'); $data = $p->parse_json(q${"test":"1.25e4"}$); is($data->{test}, '1.25e4', '1.25e4'); $data = $p->parse_json(q$[]$); is_deeply($data, [], '[]'); $data = $p->parse_json(q${}$); is_deeply($data, {}, '{}'); $data = $p->parse_json(<<'JSON'); [ { "precision": "zip", "Latitude": 37.7668, "Longitude": -122.3959, "Address": "", "City": "SAN FRANCISCO", "State": "CA", "Zip": "94107", "Country": "US" }, { "precision": "zip", "Latitude": 37.371991, "Longitude": -122.026020, "Address": "", "City": "SUNNYVALE", "State": "CA", "Zip": "94085", "Country": "US" } ] JSON is_deeply($data, [ { "precision"=>"zip", Latitude => "37.7668", Longitude=>"-122.3959", "Country" => "US", Zip => 94107, Address => '', City => "SAN FRANCISCO", State => 'CA' }, { "precision" => "zip", Longitude => "-122.026020", Address => "", City => "SUNNYVALE", Country => "US", Latitude => "37.371991", Zip => 94085, State => "CA" } ], 'Geo data'); $data = $p->parse_json(<<'JSON'); { "Image": { "Width": 800, "Height": 600, "Title": "View from 15th Floor", "Thumbnail": { "Url": "http://www.example.com/image/481989943", "Height": 125, "Width": "100" }, "IDs": [116, 943, 234, 38793] } } JSON is_deeply($data, { "Image" => { "Width" => 800, "Height" => 600, "Title" => "View from 15th Floor", "Thumbnail" => { "Url" => "http://www.example.com/image/481989943", "Height" => 125, "Width" => 100, }, "IDs" => [ 116, 943, 234, 38793 ], } }, 'is_deeply test'); my $big_test = <<'JSON'; { "source" : "Janetter", "entities" : { "user_mentions" : [ { "name" : "James Governor", "screen_name" : "moankchips", "indices" : [ 0, 10 ], "id_str" : "61233", "id" : 61233 } ], "media" : [ ], "hashtags" : [ ], "urls" : [ ] }, "in_reply_to_status_id_str" : "281400879465238529", "geo" : { }, "id_str" : "281405942321532929", "in_reply_to_user_id" : 61233, "text" : "@monkchips Ouch. Some regrets are harsher than others.", "id" : 281405942321532929, "in_reply_to_status_id" : 281400879465238529, "created_at" : "Wed Dec 19 14:29:39 +0000 2012", "in_reply_to_screen_name" : "monkchips", "in_reply_to_user_id_str" : "61233", "user" : { "name" : "Sarah Bourne", "screen_name" : "sarahebourne", "protected" : false, "id_str" : "16010789", "profile_image_url_https" : "https://si0.twimg.com/profile_images/638441870/Snapshot-of-sb_normal.jpg", "id" : 16010789, "verified" : false } } JSON $data = $p->parse_json($big_test); is_deeply $data, eval q{ { 'source' => 'Janetter', 'geo' => {}, 'in_reply_to_user_id_str' => '61233', 'id_str' => '281405942321532929', 'entities' => { 'hashtags' => [], 'media' => [], 'user_mentions' => [ { 'name' => 'James Governor', 'id' => '61233', 'id_str' => '61233', 'indices' => [ '0', '10' ], 'screen_name' => 'moankchips' } ], 'urls' => [] }, 'created_at' => 'Wed Dec 19 14:29:39 +0000 2012', 'in_reply_to_status_id_str' => '281400879465238529', 'text' => '@monkchips Ouch. Some regrets are harsher than others.', 'user' => { 'protected' => '', 'name' => 'Sarah Bourne', 'verified' => '', 'id' => '16010789', 'id_str' => '16010789', 'profile_image_url_https' => 'https://si0.twimg.com/profile_images/638441870/Snapshot-of-sb_normal.jpg', 'screen_name' => 'sarahebourne' }, 'in_reply_to_user_id' => '61233', 'id' => '281405942321532929', 'in_reply_to_status_id' => '281400879465238529', 'in_reply_to_screen_name' => 'monkchips' } }, "big test"; $data = $p->parse_json(<<'JSON'); { "test": "\u2603" } JSON is($data->{test}, "\x{2603}", 'Unicode char'); package MarpaX::JSON; sub new { my ($class) = @_; my $parser = bless {}, $class; $parser->{grammar} = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :default ::= action => [lhs,values] lexeme default = action => [lhs,value] json ::= object | array object ::= ('{' '}') | ('{') members ('}') members ::= pair* separator => [,] pair ::= string (':') value value ::= string | object | number | array | 'true' | 'false' | 'null' array ::= ('[' ']') | ('[') elements (']') elements ::= value+ separator => [,] number ~ int | int frac | int exp | int frac exp int ~ digits | '-' digits digits ~ [\d]+ frac ~ '.' digits exp ~ e digits e ~ 'e' | 'e+' | 'e-' | 'E' | 'E+' | 'E-' string ::= lstring lstring ~ quote in_string quote quote ~ ["] in_string ~ in_string_char* in_string_char ~ [^"] | '\"' :discard ~ whitespace whitespace ~ [\s]+ END_OF_SOURCE } ); return $parser; } sub parse { my ( $parser, $string ) = @_; my $re = Marpa::R2::Scanless::R->new( { grammar => $parser->{grammar}, } ); $re->read( \$string ); my $ast = ${ $re->value() }; return $parser->decode ( $ast ); } ## end sub parse sub decode { my $parser = shift; my $ast = shift; if (ref $ast){ my ($id, @nodes) = @$ast; $id = $parser->{grammar}->symbol_display_form($id); if ($id eq 'json'){ $parser->decode(@nodes); } elsif ($id eq 'members'){ return { map { $parser->decode($_) } @nodes }; } elsif ($id eq 'pair'){ return map { $parser->decode($_) } @nodes; } elsif ($id eq 'elements'){ return [ map { $parser->decode($_) } @nodes ]; } elsif ($id eq 'string'){ return decode_string( substr $nodes[0]->[1], 1, -1 ); } elsif ($id eq 'number'){ return $nodes[0]; } elsif ($id eq 'object'){ return {} unless @nodes; return $parser->decode($_) for @nodes; } elsif ($id eq 'array'){ return [] unless @nodes; return $parser->decode($_) for @nodes; } else{ return $parser->decode($_) for @nodes; } } else { if ($ast eq 'true' or $ast eq 'false'){ return $ast eq 'true' } elsif ($ast eq 'null' ){ return undef } else { warn "unknown scalar <$ast>"; return $ast } } } sub parse_json { my ($parser, $string) = @_; return $parser->parse($string); } sub decode_string { my ($s) = @_; $s =~ s/\\u([0-9A-Fa-f]{4})/chr(hex($1))/egxms; $s =~ s/\\n/\n/gxms; $s =~ s/\\r/\r/gxms; $s =~ s/\\b/\b/gxms; $s =~ s/\\f/\f/gxms; $s =~ s/\\t/\t/gxms; $s =~ s/\\\\/\\/gxms; $s =~ s{\\/}{/}gxms; $s =~ s{\\"}{"}gxms; return $s; } ## end sub decode_string 1; Marpa-R2-2.086000~dfsg/t/leo_unit.t0000444000000000000000000000654312342464707015317 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test of Leo logic for unit rule. use 5.010; use strict; use warnings; use List::Util; use Test::More tests => 7; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub main::default_action { shift; return ( join q{}, grep {defined} @_ ); } ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'A', rules => [ [ 'A', [qw/a B/] ], [ 'B', [qw/C/] ], [ 'C', [qw/c A/] ], [ 'C', [qw/c/] ], ], terminals => [qw(a c)], default_action => 'main::default_action', } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_symbols(), <<'END_OF_STRING', 'Leo166 Symbols' ); 0: a, terminal 1: c, terminal 2: A 3: B 4: C END_OF_STRING Marpa::R2::Test::is( $grammar->show_rules, <<'END_OF_STRING', 'Leo166 Rules' ); 0: A -> a B 1: B -> C 2: C -> c A 3: C -> c END_OF_STRING Marpa::R2::Test::is( $grammar->show_ahms, <<'END_OF_STRING', 'Leo166 AHMs' ); AHM 0: postdot = "a" A ::= . a B AHM 1: postdot = "B" A ::= a . B AHM 2: completion A ::= a B . AHM 3: postdot = "C" B ::= . C AHM 4: completion B ::= C . AHM 5: postdot = "c" C ::= . c A AHM 6: postdot = "A" C ::= c . A AHM 7: completion C ::= c A . AHM 8: postdot = "c" C ::= . c AHM 9: completion C ::= c . AHM 10: postdot = "A" A['] ::= . A AHM 11: completion A['] ::= A . END_OF_STRING my $input = 'acacac'; my $length_of_input = length $input; LEO_FLAG: for my $leo_flag ( 0, 1 ) { my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, leo => $leo_flag } ); my $i = 0; my $latest_earley_set = $recce->latest_earley_set(); my @sizes = ($recce->earley_set_size($latest_earley_set)); TOKEN: for ( my $i = 0; $i < $length_of_input; $i++ ) { my $token_name = substr( $input, $i, 1 ); # token name and value are the same $recce->read( $token_name, $token_name ); $latest_earley_set = $recce->latest_earley_set(); push @sizes, $recce->earley_set_size($latest_earley_set); } ## end TOKEN: for ( my $i = 0; $i < $length_of_input; $i++ ) my $max_size = List::Util::max(@sizes); my $expected_size = $leo_flag ? 5 : ( $length_of_input / 2 ) * 3 + 3; Marpa::R2::Test::is( $max_size, $expected_size, "Leo flag $leo_flag, size was $max_size but $expected_size was expected" ); my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; Marpa::R2::Test::is( $value, 'acacac', 'Leo unit rule parse' ); } ## end LEO_FLAG: for my $leo_flag ( 0, 1 ) # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_fullsyn.t0000444000000000000000000000702012342464706015661 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # A "full" Synopsis for the intro doc to the SLIF use 5.010; use strict; use warnings; use Test::More tests => 1; use English qw( -no_match_vars ); use Scalar::Util; use lib 'inc'; use Marpa::R2::Test; ## no critic (ErrorHandling::RequireCarping); # Marpa::R2::Display # name: SLIF full synopsis use Marpa::R2; my $grammar = Marpa::R2::Scanless::G->new( { bless_package => 'My_Nodes', source => \(<<'END_OF_SOURCE'), :default ::= action => [values] bless => ::lhs lexeme default = action => [ start, length, value ] bless => ::name latm => 1 :start ::= Script Script ::= Expression+ separator => comma comma ~ [,] Expression ::= Number bless => primary | '(' Expression ')' bless => paren assoc => group || Expression '**' Expression bless => exponentiate assoc => right || Expression '*' Expression bless => multiply | Expression '/' Expression bless => divide || Expression '+' Expression bless => add | Expression '-' Expression bless => subtract Number ~ [\d]+ :discard ~ whitespace whitespace ~ [\s]+ # allow comments :discard ~ ~ | ~ '#' ~ '#' ~ * ~ [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] ~ [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] END_OF_SOURCE } ); my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); my $input = '42*2+7/3, 42*(2+7)/3, 2**7-3, 2**(7-3)'; $recce->read(\$input); my $value_ref = $recce->value(); die "No parse was found\n" if not defined $value_ref; # Result will be something like "86.33... 126 125 16" # depending on the floating point precision my $result = ${$value_ref}->doit(); package My_Nodes; sub My_Nodes::primary::doit { return $_[0]->[0]->doit() } sub My_Nodes::Number::doit { return $_[0]->[2] } sub My_Nodes::paren::doit { my ($self) = @_; $self->[1]->doit() } sub My_Nodes::add::doit { my ($self) = @_; $self->[0]->doit() + $self->[2]->doit(); } sub My_Nodes::subtract::doit { my ($self) = @_; $self->[0]->doit() - $self->[2]->doit(); } sub My_Nodes::multiply::doit { my ($self) = @_; $self->[0]->doit() * $self->[2]->doit(); } sub My_Nodes::divide::doit { my ($self) = @_; $self->[0]->doit() / $self->[2]->doit(); } sub My_Nodes::exponentiate::doit { my ($self) = @_; $self->[0]->doit()**$self->[2]->doit(); } sub My_Nodes::Script::doit { my ($self) = @_; return join q{ }, map { $_->doit() } @{$self}; } # Marpa::R2::Display::End package main; Test::More::like( $result, qr/\A 86[.]3\d+ \s+ 126 \s+ 125 \s+ 16\z/xms, 'Value of scannerless parse' ); # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/thin_eq.t0000444000000000000000000002312612342464706015123 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Testing an ambiguous equation # using the thin interface use 5.010; use strict; use warnings; use Test::More tests => 12; use lib 'inc'; use Marpa::R2::Test; use English qw( -no_match_vars ); use Fatal qw( close open ); use Marpa::R2; # Marpa::R2::Display # name: Thin example my $grammar = Marpa::R2::Thin::G->new( { if => 1 } ); $grammar->force_valued(); my $symbol_S = $grammar->symbol_new(); my $symbol_E = $grammar->symbol_new(); $grammar->start_symbol_set($symbol_S); my $symbol_op = $grammar->symbol_new(); my $symbol_number = $grammar->symbol_new(); my $start_rule_id = $grammar->rule_new( $symbol_S, [$symbol_E] ); my $op_rule_id = $grammar->rule_new( $symbol_E, [ $symbol_E, $symbol_op, $symbol_E ] ); my $number_rule_id = $grammar->rule_new( $symbol_E, [$symbol_number] ); $grammar->precompute(); my $recce = Marpa::R2::Thin::R->new($grammar); $recce->start_input(); # The numbers from 1 to 3 are themselves -- # that is, they index their own token value. # Important: zero cannot be itself! my @token_values = ( 0 .. 3 ); my $zero = -1 + push @token_values, 0; my $minus_token_value = -1 + push @token_values, q{-}; my $plus_token_value = -1 + push @token_values, q{+}; my $multiply_token_value = -1 + push @token_values, q{*}; $recce->alternative( $symbol_number, 2, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_op, $minus_token_value, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_number, $zero, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_op, $multiply_token_value, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_number, 3, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_op, $plus_token_value, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_number, 1, 1 ); $recce->earleme_complete(); my $latest_earley_set_ID = $recce->latest_earley_set(); my $bocage = Marpa::R2::Thin::B->new( $recce, $latest_earley_set_ID ); my $order = Marpa::R2::Thin::O->new($bocage); my $tree = Marpa::R2::Thin::T->new($order); my @actual_values = (); while ( $tree->next() ) { my $valuator = Marpa::R2::Thin::V->new($tree); my @stack = (); STEP: while ( 1 ) { my ( $type, @step_data ) = $valuator->step(); last STEP if not defined $type; if ( $type eq 'MARPA_STEP_TOKEN' ) { my ( undef, $token_value_ix, $arg_n ) = @step_data; $stack[$arg_n] = $token_values[$token_value_ix]; next STEP; } if ( $type eq 'MARPA_STEP_RULE' ) { my ( $rule_id, $arg_0, $arg_n ) = @step_data; if ( $rule_id == $start_rule_id ) { my ( $string, $value ) = @{ $stack[$arg_n] }; $stack[$arg_0] = "$string == $value"; next STEP; } if ( $rule_id == $number_rule_id ) { my $number = $stack[$arg_0]; $stack[$arg_0] = [ $number, $number ]; next STEP; } if ( $rule_id == $op_rule_id ) { my $op = $stack[ $arg_0 + 1 ]; my ( $right_string, $right_value ) = @{ $stack[$arg_n] }; my ( $left_string, $left_value ) = @{ $stack[$arg_0] }; my $value; my $text = '(' . $left_string . $op . $right_string . ')'; if ( $op eq q{+} ) { $stack[$arg_0] = [ $text, $left_value + $right_value ]; next STEP; } if ( $op eq q{-} ) { $stack[$arg_0] = [ $text, $left_value - $right_value ]; next STEP; } if ( $op eq q{*} ) { $stack[$arg_0] = [ $text, $left_value * $right_value ]; next STEP; } die "Unknown op: $op"; } ## end if ( $rule_id == $op_rule_id ) die "Unknown rule $rule_id"; } ## end if ( $type eq 'MARPA_STEP_RULE' ) die "Unexpected step type: $type"; } ## end while ( my ( $type, @step_data ) = $valuator->step() ) push @actual_values, $stack[0]; } ## end while ( $tree->next() ) # Marpa::R2::Display::End my %expected_value = ( '(2-(0*(3+1))) == 2' => 1, '(((2-0)*3)+1) == 7' => 1, '((2-(0*3))+1) == 3' => 1, '((2-0)*(3+1)) == 8' => 1, '(2-((0*3)+1)) == 1' => 1, ); my $i = 0; for my $actual_value (@actual_values) { if ( defined $expected_value{$actual_value} ) { delete $expected_value{$actual_value}; Test::More::pass("Expected Value $i: $actual_value"); } else { Test::More::fail("Unexpected Value $i: $actual_value"); } $i++; } ## end for my $actual_value (@actual_values) # For the error methods, start clean, # with a new, trivial grammar $grammar = $recce = $bocage = $order = $tree = undef; $grammar = Marpa::R2::Thin::G->new( { if => 1 } ); $grammar->force_valued(); # Marpa::R2::Display # name: Thin throw_set() example $grammar->throw_set(0); # Marpa::R2::Display::End # Turn it right back on, for safety's sake $grammar->throw_set(1); # Marpa::R2::Display # name: Thin grammar error methods my ( $error_code, $error_description ) = $grammar->error(); my @error_names = Marpa::R2::Thin::error_names(); my $error_name = $error_names[$error_code]; # Marpa::R2::Display::End Test::More::is( $error_code, 0, 'Grammar error code' ); Test::More::is( $error_name, 'MARPA_ERR_NONE', 'Grammar error name' ); Test::More::is( $error_description, 'No error', 'Grammar error description' ); $symbol_S = $grammar->symbol_new(); my $symbol_a = $grammar->symbol_new(); my $symbol_sep = $grammar->symbol_new(); $grammar->start_symbol_set($symbol_S); # Marpa::R2::Display # name: Thin sequence_new() example my $sequence_rule_id = $grammar->sequence_new( $symbol_S, $symbol_a, { separator => $symbol_sep, proper => 0, min => 1 } ); # Marpa::R2::Display::End $grammar->precompute(); my @events; my $event_ix = $grammar->event_count(); while ( $event_ix-- ) { # Marpa::R2::Display # name: Thin event() example my ( $event_type, $value ) = $grammar->event( $event_ix++ ); # Marpa::R2::Display::End } $recce = Marpa::R2::Thin::R->new($grammar); # Marpa::R2::Display # name: Thin ruby_slippers_set() example $recce->ruby_slippers_set(1); # Marpa::R2::Display::End $recce->start_input(); $recce->alternative( $symbol_a, 1, 1 ); $recce->earleme_complete(); # Marpa::R2::Display # name: Thin terminals_expected() example my @terminals = $recce->terminals_expected(); # Marpa::R2::Display::End Test::More::is( (scalar @terminals), 1, 'count of terminals expected' ); Test::More::is( $terminals[0], $symbol_sep, 'expected terminal' ); my $report; # Marpa::R2::Display # name: Thin progress_item() example my $ordinal = $recce->latest_earley_set(); $recce->progress_report_start($ordinal); ITEM: while (1) { my ($rule_id, $dot_position, $origin) = $recce->progress_item(); last ITEM if not defined $rule_id; push @{$report}, [$rule_id, $dot_position, $origin]; } $recce->progress_report_finish(); # Marpa::R2::Display::End Test::More::is( ( join q{ }, map { @{$_} } @{$report} ), '0 -1 0 0 0 0', 'progress report' ); $recce->alternative( $symbol_sep, 1, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_a, 1, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_sep, 1, 1 ); $recce->earleme_complete(); $recce->alternative( $symbol_a, 1, 1 ); $recce->earleme_complete(); $latest_earley_set_ID = $recce->latest_earley_set(); $bocage = Marpa::R2::Thin::B->new( $recce, $latest_earley_set_ID ); $order = Marpa::R2::Thin::O->new($bocage); $tree = Marpa::R2::Thin::T->new($order); $tree->next(); my $valuator = Marpa::R2::Thin::V->new($tree); my $locations_report = q{}; STEP: for ( ;; ) { my ( $type, @step_data ) = $valuator->step(); last STEP if not defined $type; # Marpa::R2::Display # name: Thin location() example $type = $valuator->step_type(); my ( $start, $end ) = $valuator->location(); if ( $type eq 'MARPA_STEP_RULE' ) { my ($rule_id) = @step_data; $locations_report .= "Rule $rule_id is from $start to $end\n"; } if ( $type eq 'MARPA_STEP_TOKEN' ) { my ($token_id) = @step_data; $locations_report .= "Token $token_id is from $start to $end\n"; } if ( $type eq 'MARPA_STEP_NULLING_SYMBOL' ) { my ($symbol_id) = @step_data; $locations_report .= "Nulling symbol $symbol_id is from $start to $end\n"; } # Marpa::R2::Display::End } ## end STEP: for ( ;; ) Test::More::is( $locations_report, <<'EXPECTED', 'Step locations' ); Token 1 is from 0 to 1 Token 2 is from 1 to 2 Token 1 is from 2 to 3 Token 2 is from 3 to 4 Token 1 is from 4 to 5 Rule 0 is from 0 to 5 EXPECTED # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/null_value.t0000444000000000000000000000541712342464706015645 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use Test::More tests => 1; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; package Test; # The start rule sub new { my $class = shift; return bless {}, $class } ## no critic (Subroutines::RequireArgUnpacking) sub rule0 { return $_[1] . ', but ' . $_[2]; } ## use critic sub rule1 { return 'A is missing' } sub rule2 { return q{I'm sometimes null and sometimes not} } sub rule3 { return 'B is missing' } sub rule4 { return 'C is missing' } sub rule5 { return 'C matches Y' } sub rule6 { return 'Zorro was here' } package Test_Grammar; $Test_Grammar::MARPA_OPTIONS = [ { 'rules' => [ { 'action' => 'rule0', 'lhs' => 's', 'rhs' => [ 'a', 'y' ] }, { 'lhs' => 'a', 'rhs' => [], action => 'rule1', }, { 'action' => 'rule2', 'lhs' => 'a', 'rhs' => [ 'b', 'c' ] }, { 'lhs' => 'b', 'rhs' => [], action => 'rule3' }, { 'lhs' => 'c', 'rhs' => [], action => 'rule4' }, { 'action' => 'rule5', 'lhs' => 'c', 'rhs' => ['y'] }, { 'action' => 'rule6', 'lhs' => 'y', 'rhs' => ['Z'] } ], 'start' => 's', 'terminals' => ['Z'], 'action_object' => 'Test' } ]; package main; my $g = Marpa::R2::Grammar->new( @{$Test_Grammar::MARPA_OPTIONS} ); $g->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $g } ); $recce->read( 'Z', 'Z' ); my $ref_value = $recce->value(); my $value = $ref_value ? ${$ref_value} : 'No parse'; Marpa::R2::Test::is( $value, 'A is missing, but Zorro was here', 'null value example' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_advent.t0000444000000000000000000001344512342464707015457 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # This example is from a Perl 6 advent blog post # (Day 18 2013) by Dwarring, adapted to Marpa by Jean-Damien # Durand. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use utf8; use open ':std', ':encoding(utf8)'; use Test::More tests => 54; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $base_dsl = <<'END_OF_BASE_DSL'; :start ::= deal deal ::= hands hands ::= hand | hands ';' hand hand ::= card card card card card card ~ face suit face ~ [2-9jqka] | '10' WS ~ [\s] :discard ~ WS :lexeme ~ pause => after event => 'card' END_OF_BASE_DSL my @tests = (); push @tests, [ '2♥ 5♥ 7♦ 8♣ 9♠', 'Parse OK', 'Hand was 2♥ 5♥ 7♦ 8♣ 9♠', ]; push @tests, [ '2♥ a♥ 7♦ 8♣ j♥', 'Parse OK', 'Hand was 2♥ a♥ 7♦ 8♣ j♥', ]; push @tests, [ 'a♥ a♥ 7♦ 8♣ j♥', 'Parse stopped by application', 'Duplicate card a♥' ]; push @tests, [ 'a♥ 7♥ 7♦ 8♣ j♥; 10♥ j♥ q♥ k♥ a♥', 'Parse stopped by application', 'Duplicate card j♥' ]; push @tests, [ '2♥ 7♥ 2♦ 3♣ 3♦', 'Parse OK', 'Hand was 2♥ 7♥ 2♦ 3♣ 3♦', ]; push @tests, [ '2♥ 7♥ 2♦ 3♣', 'Parse reached end of input, but failed', 'No hands were found' ]; push @tests, [ '2♥ 7♥ 2♦ 3♣ 3♦ 1♦', 'Parse failed before end', <<'END_OF_MESSAGE' Error in SLIF parse: No lexeme found at line 1, column 16 * String before error: 2\x{2665} 7\x{2665} 2\x{2666} 3\x{2663} 3\x{2666}\s * The error was at line 1, column 16, and at character 0x0031 '1', ... * here: 1\x{2666} END_OF_MESSAGE ]; push @tests, [ '2♥ 7♥ 2♦ 3♣', 'Parse reached end of input, but failed', 'No hands were found' ]; push @tests, [ 'a♥ 7♥ 7♦ 8♣ j♥; 10♥ j♣ q♥ k♥', 'Parse failed after finding hand(s)', 'Last hand successfully parsed was a♥ 7♥ 7♦ 8♣ j♥' ]; my @suit_line = ( [ 'suit ~ [\x{2665}\x{2666}\x{2663}\x{2660}]', 'hex' ], [ 'suit ~ [♥♦♣♠]', 'char class' ], [ q{suit ~ '♥' | '♦' | '♣'| '♠'}, 'strings' ], ); for my $test_data (@tests) { my ( $input, $expected_result, $expected_value ) = @{$test_data}; my ( $actual_result, $actual_value ); for my $suit_line_data (@suit_line) { my ( $suit_line, $suit_line_type ) = @{$suit_line_data}; PROCESSING: { # Note: in production, you would compute the three grammar variants # ahead of time. my $full_dsl = $base_dsl . $suit_line; my $grammar = Marpa::R2::Scanless::G->new( { source => \$full_dsl } ); my $re = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); my $length = length $input; my %played = (); my $pos; my $eval_ok = eval { $pos = $re->read( \$input ); 1 }; while ( $eval_ok and $pos < $length ) { # In our example there is a single event: no need to ask Marpa what it is my ( $start, $length ) = $re->g1_location_to_span( $re->current_g1_location() ); my $card = $re->literal( $start, $length ); if ( ++$played{$card} > 1 ) { $actual_result = 'Parse stopped by application'; $actual_value = "Duplicate card " . $card; last PROCESSING; } $eval_ok = eval { $pos = $re->resume(); 1 }; } ## end while ( $eval_ok and $pos < $length ) if ( not $eval_ok ) { $actual_result = "Parse failed before end"; $actual_value = $EVAL_ERROR; $actual_value =~ s/ ^ Marpa::R2 \s+ exception \s+ at \s .* \z//xms; last PROCESSING; } ## end if ( not $eval_ok ) my $value_ref = $re->value(); my $last_hand; my ( $start, $end ) = $re->last_completed_range('hand'); if ( defined $start ) { $last_hand = $re->range_to_string( $start, $end ); } if ($value_ref) { $actual_result = 'Parse OK'; $actual_value = "Hand was $last_hand"; last PROCESSING; } if ( defined $last_hand ) { $actual_result = 'Parse failed after finding hand(s)'; $actual_value = "Last hand successfully parsed was $last_hand"; last PROCESSING; } ## end if ( defined $last_hand ) $actual_result = 'Parse reached end of input, but failed'; $actual_value = 'No hands were found'; } ## end PROCESSING: Marpa::R2::Test::is( $actual_result, $expected_result, "Result of $input using $suit_line_type" ); Marpa::R2::Test::is( $actual_value, $expected_value, "Value of $input using $suit_line_type" ); } ## end for my $suit_line_data (@suit_line) } ## end for my $test_data (@tests) # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_gie.t0000444000000000000000000000765712342464707014752 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Tests requiring a grammar, an input and the expected events -- # no semantics required and output is not tested. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Test::More tests => 2; use lib 'inc'; use Marpa::R2::Test; ## no critic (ErrorHandling::RequireCarping); use Marpa::R2; my $DEBUG = 0; my @tests_data = (); # Location 0 events # Bug found by Jean-Damien Durand my $loc0_dsl = < event '^${_}' = predicted <$_> event '${_}[]' = nulled <$_> EVENTS } ## end foreach ( qw/Script/, ( map {"digits$_"} ( 1 .. 2 ) ), ( ...)) my $loc0_input = ' 1 2'; my $loc0_grammar = Marpa::R2::Scanless::G->new( { source => \$loc0_dsl } ); my $loc0_events = <<'END_OF_EXPECTED_EVENTS'; ^Script ^digits1 null1[] null2[] ^digits2 digits1$ null3[] null4[] Script$ digits2$ null5[] END_OF_EXPECTED_EVENTS push @tests_data, [ $loc0_grammar, $loc0_input, $loc0_events, 'Location 0 events' ]; my $reject_dup_dsl = <<'END_OF_DSL'; :start ::= Script Script ::= 'x' DUP 'y' _S ~ [\s] _S_MANY ~ _S+ _S_ANY ~ _S* :lexeme ~ pause => after event => 'DUP$' DUP ~ _S_ANY _S | _S _S_ANY :discard ~ _S_MANY END_OF_DSL my $reject_dup_grammar = Marpa::R2::Scanless::G->new( { source => \$reject_dup_dsl } ); my $reject_dup_input = " x y\n\n"; my $reject_dup_events = join "\n", 'DUP$', q{}, q{}; push @tests_data, [ $reject_dup_grammar, $reject_dup_input, $reject_dup_events, 'Events for rejected duplicates' ]; TEST: for my $test_data (@tests_data) { my ( $grammar, $test_string, $expected_events, $test_name ) = @{$test_data}; my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); my $pos = -1; my $length = length $test_string; my $actual_events = q{}; for ( my $pass = 0; $pos < $length; $pass++ ) { my $eval_ok; if ($pass) { $eval_ok = eval { $pos = $recce->resume(); 1 }; } else { $eval_ok = eval { $pos = $recce->read( \$test_string ); 1 }; } die $EVAL_ERROR if not $eval_ok; $actual_events .= record_events($recce); } ## end for ( my $pass = 0; $pos < $length; $pass++ ) Test::More::is( $actual_events, $expected_events, $test_name ); } ## end for my $test_data (@tests_data) sub record_events { my ( $recce, $pos ) = @_; my $text = q{}; my @events; for ( my $event_ix = 0; my $event = $recce->event($event_ix); $event_ix++ ) { my ( $event_name, @event_data ) = @{$event}; push @events, $event_name; } ## end for ( my $event_ix = 0; my $event = $recce->event($event_ix...)) return ( join q{ }, sort @events ) . "\n"; } ## end sub record_events 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/syn_engine.t0000444000000000000000000001011612342464706015625 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Engine Synopsis use 5.010; use strict; use warnings; use Test::More tests => 3; use lib 'inc'; use Marpa::R2::Test; ## no critic (ErrorHandling::RequireCarping); # Marpa::R2::Display # name: Engine Synopsis Unambiguous Parse use Marpa::R2; my $grammar = Marpa::R2::Grammar->new( { start => 'Expression', actions => 'My_Actions', default_action => 'first_arg', rules => [ { lhs => 'Expression', rhs => [qw/Term/] }, { lhs => 'Term', rhs => [qw/Factor/] }, { lhs => 'Factor', rhs => [qw/Number/] }, { lhs => 'Term', rhs => [qw/Term Add Term/], action => 'do_add' }, { lhs => 'Factor', rhs => [qw/Factor Multiply Factor/], action => 'do_multiply' }, ], } ); $grammar->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); $recce->read( 'Number', 42 ); $recce->read('Multiply'); $recce->read( 'Number', 1 ); $recce->read('Add'); $recce->read( 'Number', 7 ); sub My_Actions::do_add { my ( undef, $t1, undef, $t2 ) = @_; return $t1 + $t2; } sub My_Actions::do_multiply { my ( undef, $t1, undef, $t2 ) = @_; return $t1 * $t2; } sub My_Actions::first_arg { shift; return shift; } my $value_ref = $recce->value; my $value = $value_ref ? ${$value_ref} : 'No Parse'; # Marpa::R2::Display::End # Ambiguous, Array Form Rules # Marpa::R2::Display # name: Engine Synopsis Ambiguous Parse use Marpa::R2; my $ambiguous_grammar = Marpa::R2::Grammar->new( { start => 'E', actions => 'My_Actions', rules => [ [ 'E', [qw/E Add E/], 'do_add' ], [ 'E', [qw/E Multiply E/], 'do_multiply' ], [ 'E', [qw/Number/], ], ], default_action => 'first_arg', } ); $ambiguous_grammar->precompute(); my $ambiguous_recce = Marpa::R2::Recognizer->new( { grammar => $ambiguous_grammar } ); $ambiguous_recce->read( 'Number', 42 ); $ambiguous_recce->read('Multiply'); $ambiguous_recce->read( 'Number', 1 ); $ambiguous_recce->read('Add'); $ambiguous_recce->read( 'Number', 7 ); my @values = (); while ( defined( my $ambiguous_value_ref = $ambiguous_recce->value() ) ) { push @values, ${$ambiguous_value_ref}; } # Marpa::R2::Display::End Test::More::is( $value, 49, 'Unambiguous Value' ); Test::More::is_deeply( [ sort @values ], [ 336, 49 ], 'Ambiguous Values' ); # An example of "Ruby Slippers" lexing, using # the unambiguous grammar. sub fix_things { my ($recce, $tokens, $token_ix) = @_; die qq{Don't know how to fix things at $token_ix}; } # Marpa::R2::Display # name: Engine Synopsis Interactive Parse $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); my @tokens = ( [ 'Number', 42 ], ['Multiply'], [ 'Number', 1 ], ['Add'], [ 'Number', 7 ], ); TOKEN: for ( my $token_ix = 0; $token_ix <= $#tokens; $token_ix++ ) { defined $recce->read( @{ $tokens[$token_ix] } ) or fix_things( $recce, $token_ix, \@tokens ) or die q{Don't know how to fix things}; } # Marpa::R2::Display::End $value_ref = $recce->value; $value = $value_ref ? ${$value_ref} : 'No Parse'; Test::More::is( $value, 49, 'Interactive Value' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/balanced.t0000444000000000000000000001154212342464706015224 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use List::Util qw(min); use Test::More tests => 7; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; sub find_match { my ($s) = @_; my $grammar_args = { start => 'S', rules => [ [ S => [qw(prefix first_balanced endmark )] ], { lhs => 'S', rhs => [qw(prefix first_balanced )] }, { lhs => 'prefix', rhs => [qw(prefix_char)], min => 0 }, { lhs => 'prefix_char', rhs => [qw(xlparen)] }, { lhs => 'prefix_char', rhs => [qw(rparen)] }, { lhs => 'lparen', rhs => [qw(xlparen)] }, { lhs => 'lparen', rhs => [qw(ilparen)] }, { lhs => 'first_balanced', rhs => [qw(xlparen balanced_sequence rparen)], }, { lhs => 'balanced', rhs => [qw(lparen balanced_sequence rparen)], }, { lhs => 'balanced_sequence', rhs => [qw(balanced)], min => 0, }, ], }; my $grammar = Marpa::R2::Grammar->new($grammar_args); $grammar->precompute(); my ($first_balanced_rule) = grep { ( $grammar->rule($_) )[0] eq 'first_balanced' } $grammar->rule_ids(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); # Marpa::R2::Display # name: Recognizer expected_symbol_event_set() Synopsis $recce->expected_symbol_event_set( 'endmark', 1 ); # Marpa::R2::Display::End my $location = 0; my $string_length = length $s; my $end_of_match; # find the match which ends first -- the one which starts # first must start at or before it does CHAR: while ( $location < $string_length ) { my $value = substr $s, $location, 1; my $event_count; if ( $value eq '(' ) { # say "Adding xlparen at $location"; $event_count = $recce->read('xlparen'); } else { # say "Adding rparen at $location"; $event_count = $recce->read('rparen'); } if ( $event_count and grep { $_->[0] eq 'SYMBOL_EXPECTED' } @{ $recce->events() } ) { $end_of_match = $location + 1; last CHAR; } ## end if ( $event_count and grep { $_->[0] eq 'SYMBOL_EXPECTED'...}) $location++; } ## end CHAR: while ( $location < $string_length ) if ( not defined $end_of_match ) { say "No balanced parens"; return 0; } CHAR: while ( ++$location < $string_length ) { my $value = substr $s, $location, 1; my $token = $value eq '(' ? 'ilparen' : 'rparen'; # say "Adding $token at $location"; my $event_count = $recce->read($token); last CHAR if not defined $event_count; if ( $event_count and grep { $_->[0] eq 'SYMBOL_EXPECTED' } @{ $recce->events() } ) { $end_of_match = $location + 1; } } ## end CHAR: while ( ++$location < $string_length ) my $report = $recce->progress($end_of_match); # say Dumper($report); my $start_of_match = List::Util::min map { $_->[2] } grep { $_->[1] < 0 && $_->[0] == $first_balanced_rule } @{$report}; return "$start_of_match-$end_of_match"; } ## end sub find_match my $base_string = '(' x 40; my $target = '(()())'; for my $pos ( 0, 1, 2, -( 2 + length $target ), -( 1 + length $target ), -( length $target ) ) { my $test_string = $base_string; substr $test_string, $pos, ( length $target ), $target; my ( $expected_start, $expected_end ); if ( $pos >= 0 ) { $expected_start = $pos; $expected_end = $pos + length $target; } else { $expected_start = $pos + 40; $expected_end = $pos + 40 + length $target; } my $expected = $expected_start . q{-} . $expected_end; Marpa::R2::Test::is( find_match($test_string), $expected, "target at pos $pos" ); } ## end for my $pos ( 0, 1, 2, -( 2 + length $target ), -( 1 ...)) my $test_string = '(' x 20 . ')' x 20; Marpa::R2::Test::is( find_match($test_string), '0-40', 'Middle target' ); Marpa-R2-2.086000~dfsg/t/limits.t0000444000000000000000000001027512342464707014777 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Test::More tests => 3; use Fatal qw(open close); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . join( q{;}, @_ ) . ')'; } ## end sub default_action ## use critic sub test_grammar { my ( $grammar_args, $tokens ) = @_; my $grammar; my $eval_ok = eval { $grammar = Marpa::R2::Grammar->new($grammar_args); 1; }; die "Exception while creating Grammar:\n$EVAL_ERROR" if not $eval_ok; die "Grammar not created\n" if not $grammar; $grammar->precompute(); my $recce; $eval_ok = eval { $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); 1; }; die "Exception while creating Recognizer:\n$EVAL_ERROR" if not $eval_ok; die "Recognizer not created\n" if not $recce; for my $token ( @{$tokens} ) { my $earleme_result; $eval_ok = eval { $recce->alternative( @{$token} ); $earleme_result = $recce->earleme_complete(); 1; }; die "Exception while recognizing earleme:\n$EVAL_ERROR" if not $eval_ok; die "Parsing exhausted\n" if not defined $earleme_result; } ## end for my $token ( @{$tokens} ) $eval_ok = eval { $recce->end_input(); 1; }; die "Exception while recognizing end of input:\n$EVAL_ERROR" if not $eval_ok; my $value_ref = $recce->value(); die "No parse\n" if not $value_ref; return ${$value_ref}; } ## end sub test_grammar # RHS too long is not testable # Perl runs out of memory first # test a grammar with no limit problems my $result_on_success = '(a;a)'; my $placebo = { start => 'S', rules => [ #<<< no perltidy [ 'S', [ qw(A A) ] ], [ 'A', [qw/a/] ] #>>> ], default_action => 'main::default_action', }; sub gen_tokens { my ($earleme_length) = @_; return [ [ 'a', \'a', 1 ], [ 'a', \'a', $earleme_length ] ]; } my $value; my $eval_ok = eval { $value = test_grammar( $placebo, gen_tokens(1) ); 1; }; if ( not defined $eval_ok ) { Test::More::diag($EVAL_ERROR); Test::More::fail('Placebo grammar'); } else { Test::More::is( $value, $result_on_success, 'Placebo grammar' ) } ## lots of test values in the following, some of them pretty ## arbitrary $eval_ok = eval { $value = test_grammar( $placebo, gen_tokens(20_031) ); 1; }; if ( not defined $eval_ok ) { Test::More::fail('Earleme very long') } else { Test::More::is( $value, $result_on_success, 'Earleme very long, but still OK' ); } $eval_ok = eval { $value = test_grammar( $placebo, gen_tokens( 2**31 ) ); 1; }; REPORT_RESULT: { if ( defined $eval_ok ) { Test::More::diag("Earleme too long test returned value: $value"); Test::More::fail('Did not catch problem with earleme too long'); last REPORT_RESULT; } if ( $EVAL_ERROR =~ / \A Exception \s while \s recognizing \s earleme /xms ) { Test::More::pass('Caught over-long earleme'); last REPORT_RESULT; } ## end if ( $EVAL_ERROR =~ ...) Test::More::is( $EVAL_ERROR, q{}, 'Grammar with earleme too long' ); } ## end REPORT_RESULT: 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/implementation.t0000444000000000000000000002053112342464706016516 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use Fatal qw(open close); use Test::More tests => 8; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $grammar = Marpa::R2::Grammar->new( { start => 'Expression', actions => 'My_Actions', default_action => 'first_arg', rules => [ { lhs => 'Expression', rhs => [qw/Term/] }, { lhs => 'Term', rhs => [qw/Factor/] }, { lhs => 'Factor', rhs => [qw/Number/] }, { lhs => 'Term', rhs => [qw/Term Add Term/], action => 'do_add' }, { lhs => 'Factor', rhs => [qw/Factor Multiply Factor/], action => 'do_multiply' }, ], } ); $grammar->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); my @tokens = ( [ 'Number', 42 ], [ 'Multiply', q{*} ], [ 'Number', 1 ], [ 'Add', q{+} ], [ 'Number', 7 ], ); for my $token_and_value (@tokens) { $recce->read( @{$token_and_value} ); } sub My_Actions::do_add { my ( undef, $t1, undef, $t2 ) = @_; return $t1 + $t2; } sub My_Actions::do_multiply { my ( undef, $t1, undef, $t2 ) = @_; return $t1 * $t2; } sub My_Actions::first_arg { shift; return shift; } my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No Parse'; Marpa::R2::Test::is( 49, $value, 'Implementation Example Value 1' ); $recce->reset_evaluation(); my $show_symbols_output = $grammar->show_symbols(); Marpa::R2::Test::is( $show_symbols_output, <<'END_SYMBOLS', 'Implementation Example Symbols' ); 0: Expression 1: Term 2: Factor 3: Number, terminal 4: Add, terminal 5: Multiply, terminal END_SYMBOLS my $show_rules_output = $grammar->show_rules(); Marpa::R2::Test::is( $show_rules_output, <<'END_RULES', 'Implementation Example Rules' ); 0: Expression -> Term 1: Term -> Factor 2: Factor -> Number 3: Term -> Term Add Term 4: Factor -> Factor Multiply Factor END_RULES my $show_ahms_output = $grammar->show_ahms(); Marpa::R2::Test::is( $show_ahms_output, <<'END_AHM', 'Implementation Example AHMs' ); AHM 0: postdot = "Term" Expression ::= . Term AHM 1: completion Expression ::= Term . AHM 2: postdot = "Factor" Term ::= . Factor AHM 3: completion Term ::= Factor . AHM 4: postdot = "Number" Factor ::= . Number AHM 5: completion Factor ::= Number . AHM 6: postdot = "Term" Term ::= . Term Add Term AHM 7: postdot = "Add" Term ::= Term . Add Term AHM 8: postdot = "Term" Term ::= Term Add . Term AHM 9: completion Term ::= Term Add Term . AHM 10: postdot = "Factor" Factor ::= . Factor Multiply Factor AHM 11: postdot = "Multiply" Factor ::= Factor . Multiply Factor AHM 12: postdot = "Factor" Factor ::= Factor Multiply . Factor AHM 13: completion Factor ::= Factor Multiply Factor . AHM 14: postdot = "Expression" Expression['] ::= . Expression AHM 15: completion Expression['] ::= Expression . END_AHM my $show_earley_sets_output = $recce->show_earley_sets(); my $expected_earley_sets = <<'END_EARLEY_SETS'; Last Completed: 5; Furthest: 5 Earley Set 0 ahm14: R5:0@0-0 R5:0: Expression['] ::= . Expression ahm0: R0:0@0-0 R0:0: Expression ::= . Term ahm2: R1:0@0-0 R1:0: Term ::= . Factor ahm6: R3:0@0-0 R3:0: Term ::= . Term Add Term ahm4: R2:0@0-0 R2:0: Factor ::= . Number ahm10: R4:0@0-0 R4:0: Factor ::= . Factor Multiply Factor Earley Set 1 ahm5: R2$@0-1 R2$: Factor ::= Number . [c=R2:0@0-0; s=Number; t=\42] ahm11: R4:1@0-1 R4:1: Factor ::= Factor . Multiply Factor [p=R4:0@0-0; c=R2$@0-1] ahm3: R1$@0-1 R1$: Term ::= Factor . [p=R1:0@0-0; c=R2$@0-1] ahm7: R3:1@0-1 R3:1: Term ::= Term . Add Term [p=R3:0@0-0; c=R1$@0-1] ahm1: R0$@0-1 R0$: Expression ::= Term . [p=R0:0@0-0; c=R1$@0-1] ahm15: R5$@0-1 R5$: Expression['] ::= Expression . [p=R5:0@0-0; c=R0$@0-1] Earley Set 2 ahm12: R4:2@0-2 R4:2: Factor ::= Factor Multiply . Factor [c=R4:1@0-1; s=Multiply; t=\'*'] ahm4: R2:0@2-2 R2:0: Factor ::= . Number ahm10: R4:0@2-2 R4:0: Factor ::= . Factor Multiply Factor Earley Set 3 ahm5: R2$@2-3 R2$: Factor ::= Number . [c=R2:0@2-2; s=Number; t=\1] ahm11: R4:1@2-3 R4:1: Factor ::= Factor . Multiply Factor [p=R4:0@2-2; c=R2$@2-3] ahm13: R4$@0-3 R4$: Factor ::= Factor Multiply Factor . [p=R4:2@0-2; c=R2$@2-3] ahm11: R4:1@0-3 R4:1: Factor ::= Factor . Multiply Factor [p=R4:0@0-0; c=R4$@0-3] ahm3: R1$@0-3 R1$: Term ::= Factor . [p=R1:0@0-0; c=R4$@0-3] ahm7: R3:1@0-3 R3:1: Term ::= Term . Add Term [p=R3:0@0-0; c=R1$@0-3] ahm1: R0$@0-3 R0$: Expression ::= Term . [p=R0:0@0-0; c=R1$@0-3] ahm15: R5$@0-3 R5$: Expression['] ::= Expression . [p=R5:0@0-0; c=R0$@0-3] Earley Set 4 ahm8: R3:2@0-4 R3:2: Term ::= Term Add . Term [c=R3:1@0-3; s=Add; t=\'+'] ahm2: R1:0@4-4 R1:0: Term ::= . Factor ahm4: R2:0@4-4 R2:0: Factor ::= . Number ahm6: R3:0@4-4 R3:0: Term ::= . Term Add Term ahm10: R4:0@4-4 R4:0: Factor ::= . Factor Multiply Factor Earley Set 5 ahm5: R2$@4-5 R2$: Factor ::= Number . [c=R2:0@4-4; s=Number; t=\7] ahm11: R4:1@4-5 R4:1: Factor ::= Factor . Multiply Factor [p=R4:0@4-4; c=R2$@4-5] ahm3: R1$@4-5 R1$: Term ::= Factor . [p=R1:0@4-4; c=R2$@4-5] ahm7: R3:1@4-5 R3:1: Term ::= Term . Add Term [p=R3:0@4-4; c=R1$@4-5] ahm9: R3$@0-5 R3$: Term ::= Term Add Term . [p=R3:2@0-4; c=R1$@4-5] ahm7: R3:1@0-5 R3:1: Term ::= Term . Add Term [p=R3:0@0-0; c=R3$@0-5] ahm1: R0$@0-5 R0$: Expression ::= Term . [p=R0:0@0-0; c=R3$@0-5] ahm15: R5$@0-5 R5$: Expression['] ::= Expression . [p=R5:0@0-0; c=R0$@0-5] END_EARLEY_SETS Marpa::R2::Test::is( $show_earley_sets_output, $expected_earley_sets, 'Implementation Example Earley Sets' ); my $trace_output; open my $trace_fh, q{>}, \$trace_output; $recce->set( { trace_fh => $trace_fh, trace_values => 2 } ); $value_ref = $recce->value(); $recce->set( { trace_fh => \*STDOUT, trace_values => 0 } ); close $trace_fh; $value = $value_ref ? ${$value_ref} : 'No Parse'; Marpa::R2::Test::is( 49, $value, 'Implementation Example Value 2' ); my $expected_trace_output = <<'END_TRACE_OUTPUT'; Setting trace_values option Pushed value from R2:1@0-1S3@0: Number = \42 Popping 1 values to evaluate R2:1@0-1S3@0, rule: 2: Factor -> Number Calculated and pushed value: 42 Pushed value from R4:2@0-2S5@1: Multiply = \'*' Pushed value from R2:1@2-3S3@2: Number = \1 Popping 1 values to evaluate R2:1@2-3S3@2, rule: 2: Factor -> Number Calculated and pushed value: 1 Popping 3 values to evaluate R4:3@0-3C2@2, rule: 4: Factor -> Factor Multiply Factor Calculated and pushed value: 42 Popping 1 values to evaluate R1:1@0-3C4@0, rule: 1: Term -> Factor Calculated and pushed value: 42 Pushed value from R3:2@0-4S4@3: Add = \'+' Pushed value from R2:1@4-5S3@4: Number = \7 Popping 1 values to evaluate R2:1@4-5S3@4, rule: 2: Factor -> Number Calculated and pushed value: 7 Popping 1 values to evaluate R1:1@4-5C2@4, rule: 1: Term -> Factor Calculated and pushed value: 7 Popping 3 values to evaluate R3:3@0-5C1@4, rule: 3: Term -> Term Add Term Calculated and pushed value: 49 Popping 1 values to evaluate R0:1@0-5C3@0, rule: 0: Expression -> Term Calculated and pushed value: 49 New Virtual Rule: R5:1@0-5C0@0, rule: 5: Expression['] -> Expression Real symbol count is 1 END_TRACE_OUTPUT Marpa::R2::Test::is( $trace_output, $expected_trace_output, 'Implementation Example Trace Output' ); $recce->reset_evaluation(); $value_ref = $recce->value(); $value = $value_ref ? ${$value_ref} : 'No Parse'; Marpa::R2::Test::is( 49, $value, 'Implementation Example Value 3' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/debug_leo.t0000444000000000000000000000563612342464707015430 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; use strict; use warnings; use Test::More tests => 2; use English qw( -no_match_vars ); use Fatal qw( open close ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $progress_report = q{}; my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ { lhs => 'S', rhs => [qw/Top_sequence/] }, { lhs => 'Top_sequence', rhs => [qw/Top Top_sequence/] }, { lhs => 'Top_sequence', rhs => [qw/Top/] }, { lhs => 'Top', rhs => [qw/Upper_Middle/] }, { lhs => 'Upper_Middle', rhs => [qw/Lower_Middle/] }, { lhs => 'Lower_Middle', rhs => [qw/Bottom/] }, { lhs => 'Bottom', rhs => [qw/T/] }, ], } ); # Marpa::R2::Display::End $grammar->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); my $current_earleme; for (1 .. 20) { $current_earleme = $recce->read( 'T' ); } # The call to current earlem is Useless, # but provides an example for the docs # Marpa::R2::Display # name: current_earleme Example $current_earleme = $recce->current_earleme(); # Marpa::R2::Display::End $progress_report = $recce->show_progress(); my $value_ref = $recce->value; Test::More::ok( $value_ref, 'Parse ok?' ); # Marpa::R2::Display # name: Debug Leo Example Progress Report # start-after-line: END_PROGRESS_REPORT # end-before-line: '^END_PROGRESS_REPORT$' Marpa::R2::Test::is( $progress_report, <<'END_PROGRESS_REPORT', 'sorted progress report' ); F0 @0-20 S -> Top_sequence . P1 @20-20 Top_sequence -> . Top Top_sequence R1:1 @19-20 Top_sequence -> Top . Top_sequence F1 x20 @0...19-20 Top_sequence -> Top Top_sequence . P2 @20-20 Top_sequence -> . Top F2 @19-20 Top_sequence -> Top . P3 @20-20 Top -> . Upper_Middle F3 @19-20 Top -> Upper_Middle . P4 @20-20 Upper_Middle -> . Lower_Middle F4 @19-20 Upper_Middle -> Lower_Middle . P5 @20-20 Lower_Middle -> . Bottom F5 @19-20 Lower_Middle -> Bottom . P6 @20-20 Bottom -> . T F6 @19-20 Bottom -> T . END_PROGRESS_REPORT # Marpa::R2::Display::End 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/bocage.t0000444000000000000000000003155312342464706014717 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # This test dumps the contents of the bocage and its iterator. # The example grammar is Aycock/Horspool's # "Practical Earley Parsing", # _The Computer Journal_, Vol. 45, No. 6, pp. 620-630, # in its "NNF" form use 5.010; use strict; use warnings; use Test::More tests => 18; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub default_action { shift; my $v_count = scalar @_; return q{} if $v_count <= 0; return $_[0] if $v_count == 1; return '(' . ( join q{;}, @_ ) . ')'; } ## end sub default_action ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/A A A A/] ], [ 'A', [qw/a/] ], [ 'A', [qw/E/] ], ['E'], ], default_action => 'main::default_action', } ); $grammar->set( { terminals => ['a'], } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_rules, <<'EOS', 'Aycock/Horspool Rules' ); 0: S -> A A A A 1: A -> a 2: A -> E /* !used */ 3: E -> /* empty !used */ EOS Marpa::R2::Test::is( $grammar->show_symbols, <<'EOS', 'Aycock/Horspool Symbols' ); 0: S 1: A 2: a, terminal 3: E, nulling EOS Marpa::R2::Test::is( $grammar->show_nulling_symbols, q{E}, 'Aycock/Horspool Nulling Symbols' ); Marpa::R2::Test::is( $grammar->show_productive_symbols, q{A E S a}, 'Aycock/Horspool Productive Symbols' ); Marpa::R2::Test::is( $grammar->show_accessible_symbols, q{A E S a}, 'Aycock/Horspool Accessible Symbols' ); Marpa::R2::Test::is( $grammar->show_ahms(), <<'EOS', 'AHMs' ); AHM 0: postdot = "A" S ::= . A S[R0:1] AHM 1: postdot = "S[R0:1]" S ::= A . S[R0:1] AHM 2: completion S ::= A S[R0:1] . AHM 3: postdot = "A" S ::= . A A[] A[] A[] AHM 4: completion S ::= A A[] A[] A[] . AHM 5: postdot = "S[R0:1]" S ::= A[] . S[R0:1] AHM 6: completion S ::= A[] S[R0:1] . AHM 7: postdot = "A" S[R0:1] ::= . A S[R0:2] AHM 8: postdot = "S[R0:2]" S[R0:1] ::= A . S[R0:2] AHM 9: completion S[R0:1] ::= A S[R0:2] . AHM 10: postdot = "A" S[R0:1] ::= . A A[] A[] AHM 11: completion S[R0:1] ::= A A[] A[] . AHM 12: postdot = "S[R0:2]" S[R0:1] ::= A[] . S[R0:2] AHM 13: completion S[R0:1] ::= A[] S[R0:2] . AHM 14: postdot = "A" S[R0:2] ::= . A A AHM 15: postdot = "A" S[R0:2] ::= A . A AHM 16: completion S[R0:2] ::= A A . AHM 17: postdot = "A" S[R0:2] ::= . A A[] AHM 18: completion S[R0:2] ::= A A[] . AHM 19: postdot = "A" S[R0:2] ::= A[] . A AHM 20: completion S[R0:2] ::= A[] A . AHM 21: postdot = "a" A ::= . a AHM 22: completion A ::= a . AHM 23: postdot = "S" S['] ::= . S AHM 24: completion S['] ::= S . EOS my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); my $expected_earley_sets = <<'END_OF_SETS'; Last Completed: 3; Furthest: 3 Earley Set 0 ahm23: R10:0@0-0 R10:0: S['] ::= . S ahm0: R0:0@0-0 R0:0: S ::= . A S[R0:1] ahm3: R1:0@0-0 R1:0: S ::= . A A[] A[] A[] ahm5: R2:1@0-0 R2:1: S ::= A[] . S[R0:1] ahm7: R3:0@0-0 R3:0: S[R0:1] ::= . A S[R0:2] ahm10: R4:0@0-0 R4:0: S[R0:1] ::= . A A[] A[] ahm12: R5:1@0-0 R5:1: S[R0:1] ::= A[] . S[R0:2] ahm14: R6:0@0-0 R6:0: S[R0:2] ::= . A A ahm17: R7:0@0-0 R7:0: S[R0:2] ::= . A A[] ahm19: R8:1@0-0 R8:1: S[R0:2] ::= A[] . A ahm21: R9:0@0-0 R9:0: A ::= . a Earley Set 1 ahm22: R9$@0-1 R9$: A ::= a . [c=R9:0@0-0; s=a; t=\'a'] ahm20: R8$@0-1 R8$: S[R0:2] ::= A[] A . [p=R8:1@0-0; c=R9$@0-1] ahm18: R7$@0-1 R7$: S[R0:2] ::= A A[] . [p=R7:0@0-0; c=R9$@0-1] ahm15: R6:1@0-1 R6:1: S[R0:2] ::= A . A [p=R6:0@0-0; c=R9$@0-1] ahm11: R4$@0-1 R4$: S[R0:1] ::= A A[] A[] . [p=R4:0@0-0; c=R9$@0-1] ahm8: R3:1@0-1 R3:1: S[R0:1] ::= A . S[R0:2] [p=R3:0@0-0; c=R9$@0-1] ahm4: R1$@0-1 R1$: S ::= A A[] A[] A[] . [p=R1:0@0-0; c=R9$@0-1] ahm1: R0:1@0-1 R0:1: S ::= A . S[R0:1] [p=R0:0@0-0; c=R9$@0-1] ahm24: R10$@0-1 R10$: S['] ::= S . [p=R10:0@0-0; c=R1$@0-1] [p=R10:0@0-0; c=R2$@0-1] ahm6: R2$@0-1 R2$: S ::= A[] S[R0:1] . [p=R2:1@0-0; c=R4$@0-1] [p=R2:1@0-0; c=R5$@0-1] ahm13: R5$@0-1 R5$: S[R0:1] ::= A[] S[R0:2] . [p=R5:1@0-0; c=R7$@0-1] [p=R5:1@0-0; c=R8$@0-1] ahm21: R9:0@1-1 R9:0: A ::= . a ahm14: R6:0@1-1 R6:0: S[R0:2] ::= . A A ahm17: R7:0@1-1 R7:0: S[R0:2] ::= . A A[] ahm19: R8:1@1-1 R8:1: S[R0:2] ::= A[] . A ahm7: R3:0@1-1 R3:0: S[R0:1] ::= . A S[R0:2] ahm10: R4:0@1-1 R4:0: S[R0:1] ::= . A A[] A[] ahm12: R5:1@1-1 R5:1: S[R0:1] ::= A[] . S[R0:2] Earley Set 2 ahm22: R9$@1-2 R9$: A ::= a . [c=R9:0@1-1; s=a; t=\'a'] ahm11: R4$@1-2 R4$: S[R0:1] ::= A A[] A[] . [p=R4:0@1-1; c=R9$@1-2] ahm8: R3:1@1-2 R3:1: S[R0:1] ::= A . S[R0:2] [p=R3:0@1-1; c=R9$@1-2] ahm20: R8$@1-2 R8$: S[R0:2] ::= A[] A . [p=R8:1@1-1; c=R9$@1-2] ahm18: R7$@1-2 R7$: S[R0:2] ::= A A[] . [p=R7:0@1-1; c=R9$@1-2] ahm15: R6:1@1-2 R6:1: S[R0:2] ::= A . A [p=R6:0@1-1; c=R9$@1-2] ahm16: R6$@0-2 R6$: S[R0:2] ::= A A . [p=R6:1@0-1; c=R9$@1-2] ahm13: R5$@0-2 R5$: S[R0:1] ::= A[] S[R0:2] . [p=R5:1@0-0; c=R6$@0-2] ahm6: R2$@0-2 R2$: S ::= A[] S[R0:1] . [p=R2:1@0-0; c=R3$@0-2] [p=R2:1@0-0; c=R5$@0-2] ahm24: R10$@0-2 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-2] [p=R10:0@0-0; c=R2$@0-2] ahm13: R5$@1-2 R5$: S[R0:1] ::= A[] S[R0:2] . [p=R5:1@1-1; c=R7$@1-2] [p=R5:1@1-1; c=R8$@1-2] ahm9: R3$@0-2 R3$: S[R0:1] ::= A S[R0:2] . [p=R3:1@0-1; c=R7$@1-2] [p=R3:1@0-1; c=R8$@1-2] ahm2: R0$@0-2 R0$: S ::= A S[R0:1] . [p=R0:1@0-1; c=R4$@1-2] [p=R0:1@0-1; c=R5$@1-2] ahm14: R6:0@2-2 R6:0: S[R0:2] ::= . A A ahm17: R7:0@2-2 R7:0: S[R0:2] ::= . A A[] ahm19: R8:1@2-2 R8:1: S[R0:2] ::= A[] . A ahm21: R9:0@2-2 R9:0: A ::= . a Earley Set 3 ahm22: R9$@2-3 R9$: A ::= a . [c=R9:0@2-2; s=a; t=\'a'] ahm20: R8$@2-3 R8$: S[R0:2] ::= A[] A . [p=R8:1@2-2; c=R9$@2-3] ahm18: R7$@2-3 R7$: S[R0:2] ::= A A[] . [p=R7:0@2-2; c=R9$@2-3] ahm15: R6:1@2-3 R6:1: S[R0:2] ::= A . A [p=R6:0@2-2; c=R9$@2-3] ahm16: R6$@1-3 R6$: S[R0:2] ::= A A . [p=R6:1@1-2; c=R9$@2-3] ahm13: R5$@1-3 R5$: S[R0:1] ::= A[] S[R0:2] . [p=R5:1@1-1; c=R6$@1-3] ahm9: R3$@0-3 R3$: S[R0:1] ::= A S[R0:2] . [p=R3:1@0-1; c=R6$@1-3] ahm6: R2$@0-3 R2$: S ::= A[] S[R0:1] . [p=R2:1@0-0; c=R3$@0-3] ahm24: R10$@0-3 R10$: S['] ::= S . [p=R10:0@0-0; c=R0$@0-3] [p=R10:0@0-0; c=R2$@0-3] ahm2: R0$@0-3 R0$: S ::= A S[R0:1] . [p=R0:1@0-1; c=R3$@1-3] [p=R0:1@0-1; c=R5$@1-3] ahm9: R3$@1-3 R3$: S[R0:1] ::= A S[R0:2] . [p=R3:1@1-2; c=R7$@2-3] [p=R3:1@1-2; c=R8$@2-3] ahm21: R9:0@3-3 R9:0: A ::= . a END_OF_SETS my %tree_expected = (); $tree_expected{'(;a;a;a)'} = <<'END_OF_TEXT'; 0: o17[-] R10:1@0-3 p=ok c=ok o17[0]* ::= a17 R10:1@0-3C2@0 o17[1] ::= a18 R10:1@0-3C0@0 1: o16[c0] R2:2@0-3 p=ok c=ok o16[0]* ::= a16 R2:2@0-3C3@0 2: o15[c1] R3:2@0-3 p=ok c=ok o15[0]* ::= a15 R3:2@0-3C6@1 3: o13[c2] R6:2@1-3 p=ok c=ok o13[0]* ::= a13 R6:2@1-3C9@2 4: o9[c3] R9:1@2-3 p=ok c=ok o9[0]* ::= a9 R9:1@2-3S4@2 5: o7[p3] R6:1@1-2 p=ok c=ok o7[0]* ::= a7 R6:1@1-2C9@1 6: o5[c5] R9:1@1-2 p=ok c=ok o5[0]* ::= a5 R9:1@1-2S4@1 7: o2[p2] R3:1@0-1 p=ok c=ok o2[0]* ::= a2 R3:1@0-1C9@0 8: o1[c7] R9:1@0-1 p=ok c=ok o1[0]* ::= a1 R9:1@0-1S4@0 9: o0[p1] R2:1@0-0 p=ok c=ok o0[0]* ::= a0 R2:1@0-0S3@0 END_OF_TEXT $tree_expected{'(a;;a;a)'} = <<'END_OF_TEXT'; 0: o17[-] R10:1@0-3 p=ok c=ok o17[0] ::= a17 R10:1@0-3C2@0 o17[1]* ::= a18 R10:1@0-3C0@0 1: o18[c0] R0:2@0-3 p=ok c=ok o18[0]* ::= a19 R0:2@0-3C5@1 o18[1] ::= a20 R0:2@0-3C3@1 2: o14[c1] R5:2@1-3 p=ok c=ok o14[0]* ::= a14 R5:2@1-3C6@1 3: o13[c2] R6:2@1-3 p=ok c=ok o13[0]* ::= a13 R6:2@1-3C9@2 4: o9[c3] R9:1@2-3 p=ok c=ok o9[0]* ::= a9 R9:1@2-3S4@2 5: o7[p3] R6:1@1-2 p=ok c=ok o7[0]* ::= a7 R6:1@1-2C9@1 6: o5[c5] R9:1@1-2 p=ok c=ok o5[0]* ::= a5 R9:1@1-2S4@1 7: o4[p2] R5:1@1-1 p=ok c=ok o4[0]* ::= a4 R5:1@1-1S3@1 8: o3[p1] R0:1@0-1 p=ok c=ok o3[0]* ::= a3 R0:1@0-1C9@0 9: o1[c8] R9:1@0-1 p=ok c=ok o1[0]* ::= a1 R9:1@0-1S4@0 END_OF_TEXT $tree_expected{'(a;a;;a)'} = <<'END_OF_TEXT'; 0: o17[-] R10:1@0-3 p=ok c=ok o17[0] ::= a17 R10:1@0-3C2@0 o17[1]* ::= a18 R10:1@0-3C0@0 1: o18[c0] R0:2@0-3 p=ok c=ok o18[0] ::= a19 R0:2@0-3C5@1 o18[1]* ::= a20 R0:2@0-3C3@1 2: o19[c1] R3:2@1-3 p=ok c=ok o19[0] ::= a21 R3:2@1-3C7@2 o19[1]* ::= a22 R3:2@1-3C8@2 3: o10[c2] R8:2@2-3 p=ok c=ok o10[0]* ::= a10 R8:2@2-3C9@2 4: o9[c3] R9:1@2-3 p=ok c=ok o9[0]* ::= a9 R9:1@2-3S4@2 5: o8[p3] R8:1@2-2 p=ok c=ok o8[0]* ::= a8 R8:1@2-2S3@2 6: o6[p2] R3:1@1-2 p=ok c=ok o6[0]* ::= a6 R3:1@1-2C9@1 7: o5[c6] R9:1@1-2 p=ok c=ok o5[0]* ::= a5 R9:1@1-2S4@1 8: o3[p1] R0:1@0-1 p=ok c=ok o3[0]* ::= a3 R0:1@0-1C9@0 9: o1[c8] R9:1@0-1 p=ok c=ok o1[0]* ::= a1 R9:1@0-1S4@0 END_OF_TEXT $tree_expected{'(a;a;a;)'} = <<'END_OF_TEXT'; 0: o17[-] R10:1@0-3 p=ok c=ok o17[0] ::= a17 R10:1@0-3C2@0 o17[1]* ::= a18 R10:1@0-3C0@0 1: o18[c0] R0:2@0-3 p=ok c=ok o18[0] ::= a19 R0:2@0-3C5@1 o18[1]* ::= a20 R0:2@0-3C3@1 2: o19[c1] R3:2@1-3 p=ok c=ok o19[0]* ::= a21 R3:2@1-3C7@2 o19[1] ::= a22 R3:2@1-3C8@2 3: o12[c2] R7:2@2-3 p=ok c=ok o12[0]* ::= a12 R7:2@2-3S3@3 4: o11[p3] R7:1@2-3 p=ok c=ok o11[0]* ::= a11 R7:1@2-3C9@2 5: o9[c4] R9:1@2-3 p=ok c=ok o9[0]* ::= a9 R9:1@2-3S4@2 6: o6[p2] R3:1@1-2 p=ok c=ok o6[0]* ::= a6 R3:1@1-2C9@1 7: o5[c6] R9:1@1-2 p=ok c=ok o5[0]* ::= a5 R9:1@1-2S4@1 8: o3[p1] R0:1@0-1 p=ok c=ok o3[0]* ::= a3 R0:1@0-1C9@0 9: o1[c8] R9:1@0-1 p=ok c=ok o1[0]* ::= a1 R9:1@0-1S4@0 END_OF_TEXT $recce->read( 'a', 'a' ); $recce->read( 'a', 'a' ); $recce->read( 'a', 'a' ); Marpa::R2::Test::is( $recce->show_earley_sets(1), $expected_earley_sets, 'Aycock/Horspool Earley Sets' ); my %expected = map { ( $_ => 1 ) } qw( (a;a;a;) (a;a;;a) (a;;a;a) (;a;a;a) ); $recce->set( { max_parses => 20 } ); while ( my $value_ref = $recce->value() ) { my $tree_output = q{}; my $value = 'No parse'; if ($value_ref) { $value = ${$value_ref}; Marpa::R2::Test::is( $recce->show_tree(), $tree_expected{$value}, qq{Tree, "$value"} ); } else { Test::More::fail('Tree'); } if ( defined $expected{$value} ) { delete $expected{$value}; Test::More::pass(qq{Expected result, "$value"}); } else { Test::More::fail(qq{Unexpected result, "$value"}); } } ## end while ( my $value_ref = $recce->value() ) for my $value ( keys %expected ) { Test::More::fail(qq{Missing result, "$value"}); } my $or_node_output = <<'END_OF_TEXT'; R2:1@0-0 R0:1@0-1 R3:1@0-1 R9:1@0-1 R0:2@0-3 R2:2@0-3 R3:2@0-3 R10:1@0-3 R5:1@1-1 R3:1@1-2 R6:1@1-2 R9:1@1-2 R3:2@1-3 R5:2@1-3 R6:2@1-3 R8:1@2-2 R7:1@2-3 R7:2@2-3 R8:2@2-3 R9:1@2-3 END_OF_TEXT Marpa::R2::Test::is( $recce->show_or_nodes(), $or_node_output, 'XS Or nodes' ); my $and_node_output = <<'END_OF_TEXT'; And-node #0: R2:1@0-0S3@0 And-node #3: R0:1@0-1C9@0 And-node #2: R3:1@0-1C9@0 And-node #1: R9:1@0-1S4@0 And-node #19: R0:2@0-3C5@1 And-node #20: R0:2@0-3C3@1 And-node #16: R2:2@0-3C3@0 And-node #15: R3:2@0-3C6@1 And-node #17: R10:1@0-3C2@0 And-node #18: R10:1@0-3C0@0 And-node #4: R5:1@1-1S3@1 And-node #6: R3:1@1-2C9@1 And-node #7: R6:1@1-2C9@1 And-node #5: R9:1@1-2S4@1 And-node #21: R3:2@1-3C7@2 And-node #22: R3:2@1-3C8@2 And-node #14: R5:2@1-3C6@1 And-node #13: R6:2@1-3C9@2 And-node #8: R8:1@2-2S3@2 And-node #11: R7:1@2-3C9@2 And-node #12: R7:2@2-3S3@3 And-node #10: R8:2@2-3C9@2 And-node #9: R9:1@2-3S4@2 END_OF_TEXT Marpa::R2::Test::is( $recce->show_and_nodes(), $and_node_output, 'XS And nodes' ); my $bocage_output = <<'END_OF_TEXT'; 0: 0=R2:1@0-0 - S3 1: 1=R9:1@0-1 - S4 2: 2=R3:1@0-1 - R9:1@0-1 3: 3=R0:1@0-1 - R9:1@0-1 4: 4=R5:1@1-1 - S3 5: 5=R9:1@1-2 - S4 6: 6=R3:1@1-2 - R9:1@1-2 7: 7=R6:1@1-2 - R9:1@1-2 8: 8=R8:1@2-2 - S3 9: 9=R9:1@2-3 - S4 10: 10=R8:2@2-3 R8:1@2-2 R9:1@2-3 11: 11=R7:1@2-3 - R9:1@2-3 12: 12=R7:2@2-3 R7:1@2-3 S3 13: 13=R6:2@1-3 R6:1@1-2 R9:1@2-3 14: 14=R5:2@1-3 R5:1@1-1 R6:2@1-3 15: 15=R3:2@0-3 R3:1@0-1 R6:2@1-3 16: 16=R2:2@0-3 R2:1@0-0 R3:2@0-3 17: 17=R10:1@0-3 - R2:2@0-3 18: 17=R10:1@0-3 - R0:2@0-3 19: 18=R0:2@0-3 R0:1@0-1 R5:2@1-3 20: 18=R0:2@0-3 R0:1@0-1 R3:2@1-3 21: 19=R3:2@1-3 R3:1@1-2 R7:2@2-3 22: 19=R3:2@1-3 R3:1@1-2 R8:2@2-3 END_OF_TEXT Marpa::R2::Test::is( $recce->show_bocage(), $bocage_output, 'XS Bocage' ); 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_timeflies.t0000555000000000000000000001065712342464706016163 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # This example parses ambiguous English sentences. The target annotation # is Penn Treebank's syntactic bracketing tags. For details, see # http://www.cis.upenn.edu/~treebank/ # This example originally came from Ralf Muschall. Ruslan Shvedov # reworked my implementation, converting it to the SLIF and # Penn Treebank. Ruslan and Ralf clearly know English grammar better than # most of us native speakers. # 'time', 'fruit', and 'flies' can be nouns or verbs, 'like' can be # a preposition or a verb. This creates syntactic ambiguity shown # in the parse results. # Modifier nouns are not tagged or lexed as adjectives (JJ), because # "Nouns that are used as modifiers, whether in isolation or in sequences, # should be tagged as nouns (NN, NNS) rather than as adjectives (JJ)." # -- ftp://ftp.cis.upenn.edu/pub/treebank/doc/tagguide.ps.gz # The saying "time flies like an arrow; fruit flies like a banana" # is attributed to Groucho Marx, but there is no reason to believe # he ever said it. Apparently, the saying # first appeared on the Usenet on net.jokes in 1982. # I've documented this whole thing on Wikipedia: # http://en.wikipedia.org/wiki/Time_flies_like_an_arrow # # The permalink is: # http://en.wikipedia.org/w/index.php?title=Time_flies_like_an_arrow&oldid=311163283 use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Test::More tests => 1; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; # Marpa::R2::Display # name: SLIF "time flies" DSL synopsis my $grammar = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :default ::= action => [lhs, values ] lexeme default = action => [ lhs, value ] S ::= NP VP period NP ::= NN | DT NN | NN NNS VP ::= VBP NP | VBP PP | VBZ PP PP ::= IN NP period ~ '.' :discard ~ whitespace whitespace ~ [\s]+ DT ~ 'a' | 'an' NN ~ 'arrow' | 'banana' NNS ~ 'flies' VBZ ~ 'flies' NN ~ 'fruit':i VBP ~ 'fruit':i IN ~ 'like' VBP ~ 'like' NN ~ 'time':i VBP ~ 'time':i END_OF_SOURCE } ); # Marpa::R2::Display::End my $expected = <<'EOS'; (S (NP (NN Time)) (VP (VBZ flies) (PP (IN like) (NP (DT an) (NN arrow)))) (. .)) (S (NP (NN Time) (NNS flies)) (VP (VBP like) (NP (DT an) (NN arrow))) (. .)) (S (NP (NN Fruit)) (VP (VBZ flies) (PP (IN like) (NP (DT a) (NN banana)))) (. .)) (S (NP (NN Fruit) (NNS flies)) (VP (VBP like) (NP (DT a) (NN banana))) (. .)) EOS my $paragraph = < undef } qw{ NP VP PP period }; my @actual = (); for my $sentence (split /\n/, $paragraph){ my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); $recce->read( \$sentence ); while ( defined( my $value_ref = $recce->value() ) ) { my $value = $value_ref ? bracket ( ${$value_ref} ) : 'No parse'; push @actual, $value; } } sub bracket { my ($lhs_id, @contents) = @{ $_[0] }; my $tag = $grammar->symbol_display_form($lhs_id); state $level++; my $bracketed = exists $s_tags{$tag} ? ("\n" . (" " x ($level-1))) : ''; $tag = '.' if $tag eq 'period'; if (ref $contents[0]){ $bracketed .= "($tag " . join(' ', map { bracket($_) } @contents) . ")"; } else { $bracketed .= "($tag $contents[0])"; } $level--; return $bracketed; } Marpa::R2::Test::is( ( join "\n", @actual ) . "\n", $expected, 'Ambiguous English sentences' ); 1; # In case used as "do" file # vim: set expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/pascal.t0000444000000000000000000000533012342464707014735 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. use 5.010; # variations on # the example grammar in Aycock/Horspool "Practical Earley Parsing", # _The Computer Journal_, Vol. 45, No. 6, pp. 620-630, use strict; use warnings; use Test::More tests => 7; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; sub ah_extended { my $n = shift; my $g = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [ ('A') x $n ] ], [ 'A', [qw/a/] ], [ 'A', [qw/E/] ], ['E'], ], terminals => ['a'], # no warnings for $n equals zero warnings => ( $n ? 1 : 0 ), } ); $g->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $g } ); for my $token_ix ( 1 .. $n ) { $recce->read( 'a' ); } my @parse_counts; for my $loc ( 0 .. $n ) { my $parse_number = 0; # An arbitrary maximum is put on the number of parses -- this is for # debugging, and infinite loops happen. # Marpa::R2::Display # name: reset_evaluation Synopsis $recce->reset_evaluation(); $recce->set( { end => $loc, max_parses => 999, } ); # Marpa::R2::Display::End while ( $recce->value() ) { $parse_counts[$loc]++ } } ## end for my $loc ( 0 .. $n ) return join q{ }, @parse_counts; } ## end sub ah_extended my @answers = ( '1', '1 1', '1 2 1', '1 3 3 1', '1 4 6 4 1', '1 5 10 10 5 1', '1 6 15 20 15 6 1', '1 7 21 35 35 21 7 1', '1 8 28 56 70 56 28 8 1', '1 9 36 84 126 126 84 36 9 1', '1 10 45 120 210 252 210 120 45 10 1', ); ## no critic (ValuesAndExpressions::ProhibitMagicNumbers) for my $a ( ( 0 .. 5 ), 10 ) { ## use critic Marpa::R2::Test::is( ah_extended($a), $answers[$a], "Row $a of Pascal's triangle matches parse counts" ); } ## end for my $a ( ( 0 .. 5 ), 10 ) 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/debug_seq.t0000444000000000000000000000361112342464707015430 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Debug Sequence Example use 5.010; use strict; use warnings; use Test::More tests => 3; use English qw( -no_match_vars ); use Fatal qw( open close ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $progress_report = q{}; my $grammar = Marpa::R2::Grammar->new( { start => 'Document', rules => [ { lhs => 'Document', rhs => [qw/Stuff/], min => 1 }, ], } ); $grammar->precompute(); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar } ); # Marpa::R2::Display # name: Recognizer check_terminal Synopsis my $is_symbol_a_terminal = $recce->check_terminal('Document'); # Marpa::R2::Display::End Test::More::ok( !$is_symbol_a_terminal, 'LHS terminal?' ); my $token_ix = 0; $recce->read('Stuff'); $recce->read('Stuff'); $recce->read('Stuff'); $progress_report = $recce->show_progress(0); my $value_ref = $recce->value; Test::More::ok( $value_ref, 'Parse ok?' ); Marpa::R2::Test::is( $progress_report, << 'END_PROGRESS_REPORT', 'progress report' ); P0 @0-0 Document -> . Stuff+ END_PROGRESS_REPORT 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/infinite2.t0000444000000000000000000000561212342464707015364 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # A grammars with cycles use 5.010; use strict; use warnings; use English qw( -no_match_vars ); use Fatal qw(open close chdir); use Test::More tests => 3; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub show_a { return 'A(' . $_[1] . ')' } sub show_b { return 'B(' . $_[1] . ')' } sub default_action { shift; return join q{ }, @_ } ## use critic package Test_Grammar; $Test_Grammar::MARPA_OPTIONS = [ { 'default_action' => 'main::default_action', 'rules' => [ { 'lhs' => 's', 'rhs' => ['a'] }, { 'action' => 'main::show_a', 'lhs' => 'a', 'rhs' => ['b'] }, { 'lhs' => 'a', 'rhs' => ['a:k0'] }, { 'action' => 'main::show_b', 'lhs' => 'b', 'rhs' => ['a'] } ], 'start' => 's', 'terminals' => ['a:k0'], 'infinite_action' => 'warn' } ]; my $trace; open my $MEMORY, '>', \$trace; my $grammar = Marpa::R2::Grammar->new( { trace_file_handle => $MEMORY, infinite_action => 'warn' }, @{$Test_Grammar::MARPA_OPTIONS} ); $grammar->precompute(); close $MEMORY; Marpa::R2::Test::is( $trace, <<'EOS', 'cycle detection' ); Cycle found involving rule: 1: a -> b Cycle found involving rule: 3: b -> a EOS my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, trace_file_handle => *STDERR, } ); $recce->read( 'a:k0', 'a' ); my %expected_original = map { ( $_ => 1 ) } qw( A(B(a)) a ); my %expected = %expected_original; while ( my $value_ref = $recce->value() ) { my $value = ${$value_ref}; if ( defined $expected{$value} ) { Test::More::pass(qq{Expected value: "$value"}); delete $expected{$value}; } } ## end while ( my $value_ref = $recce->value() ) for my $missing_value ( keys %expected ) { Test::More::fail(qq{Missing value: "$missing_value"}); } 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_ambig.t0000444000000000000000000000771712342464707015262 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Tests of ambiguity detection in the target grammar # (as opposed to the SLIF DSL itself). use 5.010; use strict; use warnings; use Test::More tests => 4; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; use Data::Dumper; our $DEBUG = 0; my $source = \(<<'END_OF_SOURCE'); :default ::= action => ::array pair ::= duple | item item duple ::= item item item ::= Hesperus | Phosphorus Hesperus ::= 'a' Phosphorus ::= 'a' END_OF_SOURCE my $input = 'aa'; my $expected_value = 'Application grammar is ambiguous'; my $expected_result = <<'END_OF_MESSAGE'; Ambiguous symch at Glade=2, Symbol=: The ambiguity is from line 1, column 1 to line 1, column 2 Text is: aa There are 2 symches Symch 0 is a rule: pair ::= duple Symch 1 is a rule: pair ::= item item END_OF_MESSAGE my $test_name = 'Symch ambiguity'; my $grammar = Marpa::R2::Scanless::G->new( { source => $source } ); my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); my $is_ambiguous_parse = 1; my ( $actual_value, $actual_result ); PROCESSING: { if ( not defined eval { $recce->read( \$input ); 1 } ) { say $EVAL_ERROR if $DEBUG; my $abbreviated_error = $EVAL_ERROR; chomp $abbreviated_error; $abbreviated_error =~ s/\n.*//xms; $actual_value = 'No parse'; $actual_result = $abbreviated_error; $is_ambiguous_parse = 0; last PROCESSING; } ## end if ( not defined eval { $recce->read( \$input ); 1 }) # Marpa::R2::Display # name: ASF ambiguity reporting if ( $recce->ambiguity_metric() > 1 ) { my $asf = Marpa::R2::ASF->new( { slr => $recce } ); die 'No ASF' if not defined $asf; my $ambiguities = Marpa::R2::Internal::ASF::ambiguities($asf); # Only report the first two my @ambiguities = grep {defined} @{$ambiguities}[ 0 .. 1 ]; $actual_value = 'Application grammar is ambiguous'; $actual_result = Marpa::R2::Internal::ASF::ambiguities_show( $asf, \@ambiguities ); last PROCESSING; } ## end if ( $recce->ambiguity_metric() > 1 ) # Marpa::R2::Display::End $is_ambiguous_parse = 0; my $value_ref = $recce->value(); if ( not defined $value_ref ) { $actual_value = 'No parse'; $actual_result = 'Input read to end but no parse'; last PROCESSING; } $actual_value = ${$value_ref}; $actual_result = 'Parse OK'; last PROCESSING; } ## end PROCESSING: Test::More::is( Data::Dumper::Dumper( \$actual_value ), Data::Dumper::Dumper( \$expected_value ), qq{Value of $test_name} ); Test::More::is( $actual_result, $expected_result, qq{Result of $test_name} ); if ( !$is_ambiguous_parse ) { Test::More::fail(qq{glade_span() start}); Test::More::fail(qq{glade_span() length}); } else { $recce->series_restart(); my $asf = Marpa::R2::ASF->new( { slr => $recce } ); my $glade_id = $asf->peak; # Marpa::R2::Display # name: glade_span() example my ( $glade_start, $glade_length ) = $asf->glade_span($glade_id); # Marpa::R2::Display::End Test::More::is( $glade_start, 0, qq{glade_span() start} ); Test::More::is( $glade_length, 2, qq{glade_span() length} ); } ## end else [ if ( !$is_ambiguous_parse ) ] # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_calc.t0000444000000000000000000001673012342464707015100 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Various that share a calculator semantics use 5.010; use strict; use warnings; use Test::More tests => 6; use English qw( -no_match_vars ); use Scalar::Util qw(blessed); use lib 'inc'; use Marpa::R2::Test; ## no critic (ErrorHandling::RequireCarping); use Marpa::R2; my $calculator_grammar = Marpa::R2::Scanless::G->new( { bless_package => 'My_Nodes', source => \(<<'END_OF_SOURCE'), :default ::= action => ::array bless => ::lhs :start ::= Script Script ::= Expression+ separator => comma bless => script comma ~ [,] Expression ::= Number bless => primary | ('(') Expression (')') assoc => group bless => parens || Expression ('**') Expression assoc => right bless => power || Expression ('*') Expression bless => multiply | Expression ('/') Expression bless => divide || Expression ('+') Expression bless => add | Expression ('-') Expression bless => subtract Number ~ [\d]+ :discard ~ whitespace whitespace ~ [\s]+ # allow comments :discard ~ ~ | ~ '#' ~ '#' ~ * ~ [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] ~ [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] END_OF_SOURCE } ); my $show_rules_output = $calculator_grammar->show_rules(); $show_rules_output .= $calculator_grammar->show_rules(1, 'L0'); Marpa::R2::Test::is( $show_rules_output, <<'END_OF_SHOW_RULES_OUTPUT', 'Scanless show_rules()' ); G1 R0 Script ::= Expression + G1 R1 Expression ::= Expression G1 R2 Expression ::= Expression G1 R3 Expression ::= Expression G1 R4 Expression ::= Expression G1 R5 Expression ::= Number G1 R6 Expression ::= '(' Expression ')' G1 R7 Expression ::= Expression '**' Expression G1 R8 Expression ::= Expression '*' Expression G1 R9 Expression ::= Expression '/' Expression G1 R10 Expression ::= Expression '+' Expression G1 R11 Expression ::= Expression '-' Expression G1 R12 :start ::= Script L0 R0 comma ::= [,] L0 R1 '(' ::= [\(] L0 R2 ')' ::= [\)] L0 R3 '**' ::= [\*] [\*] L0 R4 '*' ::= [\*] L0 R5 '/' ::= [\/] L0 R6 '+' ::= [\+] L0 R7 '-' ::= [\-] L0 R8 Number ::= [\d] + L0 R9 :discard ::= whitespace L0 R10 whitespace ::= [\s] + L0 R11 :discard ::= L0 R12 ::= L0 R13 ::= L0 R14 ::= [\#] L0 R15 ::= [\#] L0 R16 ::= * L0 R17 ::= [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] L0 R18 ::= [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] L0 R19 :start_lex ::= Number L0 R20 :start_lex ::= :discard L0 R21 :start_lex ::= '(' L0 R22 :start_lex ::= ')' L0 R23 :start_lex ::= '**' L0 R24 :start_lex ::= '*' L0 R25 :start_lex ::= '/' L0 R26 :start_lex ::= '+' L0 R27 :start_lex ::= '-' L0 R28 :start_lex ::= comma END_OF_SHOW_RULES_OUTPUT do_test('Calculator 1', $calculator_grammar, '42*2+7/3, 42*(2+7)/3, 2**7-3, 2**(7-3)' => qr/\A 86[.]3\d+ \s+ 126 \s+ 125 \s+ 16\z/xms); do_test('Calculator 2', $calculator_grammar, '42*3+7, 42 * 3 + 7, 42 * 3+7' => qr/ \s* 133 \s+ 133 \s+ 133 \s* /xms); do_test('Calculator 3', $calculator_grammar, '15329 + 42 * 290 * 711, 42*3+7, 3*3+4* 4' => qr/ \s* 8675309 \s+ 133 \s+ 25 \s* /xms); my $priority_grammar = <<'END_OF_GRAMMAR'; :default ::= action => ::array :start ::= statement statement ::= () expression bless => statement | expression bless => statement expression ::= number bless => primary | variable bless => variable || sign expression bless => unary_sign || expression ('+') expression bless => add number ~ [\d]+ variable ~ [[:alpha:]] ~ [[:alnum:]]* # Marpa::R2::Display # name: SLIF lexeme rule synopsis :lexeme ~ priority => 1 # Marpa::R2::Display::End ~ 'say' sign ~ [+-] :discard ~ whitespace whitespace ~ [\s]+ END_OF_GRAMMAR do_test( 'Priority test 1', Marpa::R2::Scanless::G->new( { bless_package => 'My_Nodes', source => \$priority_grammar, } ), 'say + 42' => qr/ 42 /xms ); (my $priority_grammar2 = $priority_grammar) =~ s/priority \s+ => \s+ 1$/priority => -1/xms; do_test( 'Priority test 2', Marpa::R2::Scanless::G->new( { bless_package => 'My_Nodes', source => \$priority_grammar2, } ), 'say + 42' => qr/ 41 /xms ); sub do_test { my ( $name, $grammar, $input, $output_re, $args ) = @_; my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); $recce->read(\$input); my $value_ref = $recce->value(); if ( not defined $value_ref ) { die "No parse was found, after reading the entire input\n"; } my $parse = { variables => { say => -1 } }; my $value = ${$value_ref}->doit($parse); Test::More::like( $value, $output_re, $name ); } sub My_Nodes::script::doit { my ($self, $parse) = @_; return join q{ }, map { $_->doit($parse) } @{$self}; } sub My_Nodes::statement::doit { my ($self, $parse) = @_; return $self->[0]->doit($parse); } sub My_Nodes::add::doit { my ($self, $parse) = @_; my ( $a, $b ) = @{$self}; return $a->doit($parse) + $b->doit($parse); } sub My_Nodes::subtract::doit { my ($self, $parse) = @_; my ( $a, $b ) = @{$self}; return $a->doit($parse) - $b->doit($parse); } sub My_Nodes::multiply::doit { my ($self, $parse) = @_; my ( $a, $b ) = @{$self}; return $a->doit($parse) * $b->doit($parse); } sub My_Nodes::divide::doit { my ($self, $parse) = @_; my ( $a, $b ) = @{$self}; return $a->doit($parse) / $b->doit($parse); } sub My_Nodes::unary_sign::doit { my ($self, $parse) = @_; my ( $sign, $expression ) = @{$self}; my $unsigned_result = $expression->doit($parse); return $sign eq '+' ? $unsigned_result : -$unsigned_result; } ## end sub My_Nodes::unary_sign::doit sub My_Nodes::variable::doit { my ( $self, $parse ) = @_; my $name = $self->[0]; Marpa::R2::Context::bail(qq{variable "$name" does not exist}) if not exists $parse->{variables}->{$name}; return $parse->{variables}->{$name}; } ## end sub My_Nodes::variable::doit sub My_Nodes::primary::doit { my ($self, $parse) = @_; return $self->[0]; } sub My_Nodes::parens::doit { my ($self, $parse) = @_; return $self->[0]->doit($parse); } sub My_Nodes::power::doit { my ($self, $parse) = @_; my ( $a, $b ) = @{$self}; return $a->doit($parse)**$b->doit($parse); } # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/leo2.t0000444000000000000000000000753112342464706014337 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # The example from p. 166 of Leo's paper. use 5.010; use strict; use warnings; use Test::More tests => 9; use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; ## no critic (Subroutines::RequireArgUnpacking) sub main::default_action { shift; return ( join q{}, grep {defined} @_ ); } ## use critic my $grammar = Marpa::R2::Grammar->new( { start => 'S', rules => [ [ 'S', [qw/a S/] ], [ 'S', [], ], ], terminals => [qw(a)], default_action => 'main::default_action', } ); $grammar->precompute(); Marpa::R2::Test::is( $grammar->show_symbols(), <<'END_OF_STRING', 'Leo166 Symbols' ); 0: a, terminal 1: S END_OF_STRING Marpa::R2::Test::is( $grammar->show_rules, <<'END_OF_STRING', 'Leo166 Rules' ); 0: S -> a S 1: S -> /* empty !used */ END_OF_STRING Marpa::R2::Test::is( $grammar->show_ahms, <<'END_OF_STRING', 'Leo166 AHMs' ); AHM 0: postdot = "a" S ::= . a S AHM 1: postdot = "S" S ::= a . S AHM 2: completion S ::= a S . AHM 3: postdot = "a" S ::= . a S[] AHM 4: completion S ::= a S[] . AHM 5: postdot = "S" S['] ::= . S AHM 6: completion S['] ::= S . END_OF_STRING my $length = 50; LEO_FLAG: for my $leo_flag ( 0, 1 ) { my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, leo => $leo_flag } ); my $i = 0; # Marpa::R2::Display # name: latest_earley_set() Synopsis my $latest_earley_set = $recce->latest_earley_set(); # Marpa::R2::Display::End my $max_size = $recce->earley_set_size($latest_earley_set); TOKEN: while ( $i++ < $length ) { $recce->read( 'a', 'a' ); $latest_earley_set = $recce->latest_earley_set(); my $size = $recce->earley_set_size($latest_earley_set); $max_size = $size > $max_size ? $size : $max_size; } ## end while ( $i++ < $length ) my $expected_size = $leo_flag ? 6 : $length + 4; Marpa::R2::Test::is( $max_size, $expected_size, "Leo flag $leo_flag, size" ); my $value_ref = $recce->value(); my $value = $value_ref ? ${$value_ref} : 'No parse'; Marpa::R2::Test::is( $value, 'a' x $length, 'Leo p166 parse' ); } ## end for my $leo_flag ( 0, 1 ) { open my $trace_fh, q{>}, \( my $trace_output = q{} ); my $recce = Marpa::R2::Recognizer->new( { grammar => $grammar, leo => 0, too_many_earley_items => $length, trace_fh => $trace_fh } ); for ( 1 .. $length ) { $recce->read( 'a', 'a' ); } my $value_ref = $recce->value(); close $trace_fh; my $warning_found = ( $trace_output =~ m/Earley[ ]item[ ]count[ ()\d]*exceeds[ ]warning[ ]threshold/xms ); if ($warning_found) { Test::More::pass('Warns at earley item threshold'); } else { Marpa::R2::Test::is( $trace_output, q{}, 'Leo p166 parse' ); } my $value = $value_ref ? ${$value_ref} : 'No parse'; Marpa::R2::Test::is( $value, 'a' x $length, 'Leo p166 parse' ); } 1; # In case used as "do" file # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_gires.t0000444000000000000000000001121612342464706015300 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Tests that include a grammar, an input, and an resolution # error message, but no (or minimal?) semantics. # # The intent is that this file will contain tests of the # valuator's resolution phase use 5.010; use strict; use warnings; use Test::More tests => 4; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; use Data::Dumper; our $DEBUG = 0; my @tests_data = (); sub My_Semantics::new {} #### { my $grammar = \(<<'END_OF_SOURCE'); :start ::= test test ::= 'X' action => nowhere END_OF_SOURCE push @tests_data, [ $grammar, 'X', 'Failure in value() method', <<'END_OF_MESSAGE', Could not resolve rule action named 'nowhere' Rule was test ::= 'X' Failed resolution of action "nowhere" to My_Semantics::nowhere END_OF_MESSAGE 'Parse OK', 'Missing action' ]; } #### { # Marpa::R2::Display # name: inaccessible is fatal statement # start-after-line: END_OF_SOURCE # end-before-line: '^END_OF_SOURCE$' my $source = <<'END_OF_SOURCE'; inaccessible is fatal by default :default ::= action => [symbol, name, values] lexeme default = action => [symbol, name, value] start ::= stuff* stuff ::= a | b a ::= x b ::= x c ::= x x ::= 'x' END_OF_SOURCE # Marpa::R2::Display::End my $input = 'xxx'; my $expected_value = 'SLIF grammar failed'; push @tests_data, [ \$source, $input, $expected_value, "Inaccessible symbol: c\n", qq{test "inaccessible is fatal by default"} ]; } ### TEST: for my $test_data (@tests_data) { my ( $source, $input, $expected_value, $expected_result, $test_name ) = @{$test_data}; my ( $actual_value, $actual_result ); PROCESSING: { my $grammar; if (not defined eval { $grammar = Marpa::R2::Scanless::G->new( { source => $source } ); 1; } ) { say $EVAL_ERROR if $DEBUG; my $abbreviated_error = $EVAL_ERROR; chomp $abbreviated_error; $abbreviated_error =~ s/^ Marpa[:][:]R2 \s+ exception \s+ at \s+ .* \z//xms; $actual_value = 'SLIF grammar failed'; $actual_result = $abbreviated_error; last PROCESSING; } ## end if ( not defined eval { $grammar = Marpa::R2::Scanless::G...}) my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar, semantics_package => 'My_Semantics' } ); if ( not defined eval { $recce->read( \$input ); 1 } ) { say $EVAL_ERROR if $DEBUG; my $abbreviated_error = $EVAL_ERROR; chomp $abbreviated_error; $abbreviated_error =~ s/\n.*//xms; $actual_value = 'No parse'; $actual_result = $abbreviated_error; last PROCESSING; } ## end if ( not defined eval { $recce->read( \$input ); 1 }) my $value_ref ; if ( not defined eval { $value_ref = $recce->value(); 1 } ) { say $EVAL_ERROR if $DEBUG; my $abbreviated_error = $EVAL_ERROR; chomp $abbreviated_error; $abbreviated_error =~ s/^ Marpa[:][:]R2 \s+ exception \s+ at \s+ .* \z//xms; $actual_value = 'Failure in value() method'; $actual_result = $abbreviated_error; last PROCESSING; } if ( not defined $value_ref ) { $actual_value = 'No parse'; $actual_result = 'Input read to end but no parse'; last PROCESSING; } $actual_value = ${$value_ref}; $actual_result = 'Parse OK'; last PROCESSING; } ## end PROCESSING: Marpa::R2::Test::is( Data::Dumper::Dumper( \$actual_value ), Data::Dumper::Dumper( \$expected_value ), qq{Value of $test_name} ); Marpa::R2::Test::is( $actual_result, $expected_result, qq{Result of $test_name} ); } ## end for my $test_data (@tests_data) # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/etc/0000755000000000000000000000000012345370127014054 5ustar rootrootMarpa-R2-2.086000~dfsg/t/sl_null_example.t0000444000000000000000000000547312342464707016665 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # An ambiguous equation use 5.010; use strict; use warnings; use Test::More tests => 1; use lib 'inc'; use Marpa::R2::Test; use English qw( -no_match_vars ); use Fatal qw(open close); use Marpa::R2; ## no critic (InputOutput::RequireBriefOpen) open my $original_stdout, q{>&STDOUT}; ## use critic sub save_stdout { my $save; my $save_ref = \$save; close STDOUT; open STDOUT, q{>}, $save_ref; return $save_ref; } ## end sub save_stdout sub restore_stdout { close STDOUT; open STDOUT, q{>&}, $original_stdout; return 1; } # Marpa::R2::Display # name: SLIF null value example sub do_L { shift; return 'L(' . ( join q{;}, map { $_ // '[ERROR!]' } @_ ) . ')'; } sub do_R { return 'R(): I will never be called'; } sub do_S { shift; return 'S(' . ( join q{;}, map { $_ // '[ERROR!]' } @_ ) . ')'; } sub do_X { return 'X(' . $_[1] . ')'; } sub do_Y { return 'Y(' . $_[1] . ')'; } ## no critic (Variables::ProhibitPackageVars) our $null_A = 'null A'; our $null_B = 'null B'; our $null_L = 'null L'; our $null_R = 'null R'; our $null_X = 'null X'; our $null_Y = 'null Y'; ## use critic my $slg = Marpa::R2::Scanless::G->new( { source => \<<'END_OF_DSL', :start ::= S S ::= L R action => do_S L ::= A B X action => do_L L ::= action => null_L R ::= A B Y action => do_R R ::= action => null_R A ::= action => null_A B ::= action => null_B X ::= action => null_X X ::= 'x' action => do_X Y ::= action => null_Y Y ::= 'y' action => do_Y END_OF_DSL } ); my $slr = Marpa::R2::Scanless::R->new( { grammar => $slg, semantics_package => 'main', } ); $slr->read( \'x' ); # Marpa::R2::Display::End ## use critic # Marpa::R2::Display # name: SLIF null value example output # start-after-line: END_OF_OUTPUT # end-before-line: '^END_OF_OUTPUT$' chomp( my $expected = <<'END_OF_OUTPUT'); S(L(null A;null B;X(x));null R) END_OF_OUTPUT # Marpa::R2::Display::End my $value = $slr->value(); Marpa::R2::Test::is( ${$value}, $expected, 'Null example' ); # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_completed.t0000444000000000000000000000617512342464707016154 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test of scannerless parsing -- completion events use 5.010; use strict; use warnings; use Test::More tests => 10; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $rules = <<'END_OF_GRAMMAR'; :start ::= text text ::= * action => OK ::= subtext ::= subtext ::= '(' text ')' # Marpa::R2::Display # name: SLIF completed event statement synopsis event subtext = completed # Marpa::R2::Display::End word ~ [\w]+ :discard ~ whitespace whitespace ~ [\s]+ END_OF_GRAMMAR my $grammar = Marpa::R2::Scanless::G->new( { source => \$rules } ); do_test($grammar, q{42 ( hi 42 hi ) 7 11}, [ '( hi 42 hi )' ]); do_test($grammar, q{42 ( hi) 42 (hi ) 7 11}, [ '( hi)', '(hi )' ] ); do_test($grammar, q{(hi 42 hi)}, ['(hi 42 hi)']); do_test($grammar, q{1(2(3(4)))}, [ qw{ (4) (3(4)) (2(3(4))) } ]); do_test($grammar, q{(((1)2)3)4}, [ qw{(1) ((1)2) (((1)2)3)} ]); sub show_last_subtext { my ($slr) = @_; my ( $start, $end ) = $slr->last_completed_range('subtext'); return 'No expression was successfully parsed' if not defined $start; return $slr->range_to_string( $start, $end ); } sub do_test { my ( $slg, $string, $expected_events ) = @_; my @actual_events; my $slr = Marpa::R2::Scanless::R->new( { grammar => $grammar, semantics_package => 'My_Actions' } ); my $length = length $string; my $pos = $slr->read( \$string ); READ: while (1) { # Marpa::R2::Display # name: SLR event() method synopsis EVENT: for ( my $event_ix = 0; my $event = $slr->event($event_ix); $event_ix++ ) { my ($name) = @{$event}; if ( $name eq 'subtext' ) { push @actual_events, show_last_subtext($slr); next EVENT; } } ## end for ( my $event_ix = 0; my $event = $slr->event($event_ix...)) # Marpa::R2::Display::End last READ if $pos >= $length; $pos = $slr->resume($pos); } ## end READ: while (1) my $value_ref = $slr->value(); if ( not defined $value_ref ) { die "No parse\n"; } my $actual_value = ${$value_ref}; Test::More::is( $actual_value, q{1792}, qq{Value for "$string"} ); Test::More::is_deeply( \@actual_events, $expected_events, qq{Events for "$string"} ); } ## end sub do_test sub My_Actions::OK { return 1792 }; # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_gsyn.t0000444000000000000000000001441712342464707015156 0ustar rootroot#!/usr/bin/perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Synopsis for Scannerless version of Stuizand interface use 5.010; use strict; use warnings; use Test::More tests => 4; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; ## no critic (ErrorHandling::RequireCarping); # Marpa::R2::Display # name: Scanless grammar synopsis use Marpa::R2; my $grammar = Marpa::R2::Scanless::G->new( { source => \(<<'END_OF_SOURCE'), :default ::= action => do_first_arg :start ::= Script Script ::= Expression+ separator => comma action => do_script comma ~ [,] Expression ::= Number | '(' Expression ')' action => do_parens assoc => group || Expression '**' Expression action => do_pow assoc => right || Expression '*' Expression action => do_multiply | Expression '/' Expression action => do_divide || Expression '+' Expression action => do_add | Expression '-' Expression action => do_subtract Number ~ [\d]+ :discard ~ whitespace whitespace ~ [\s]+ # allow comments :discard ~ ~ | ~ '#' ~ '#' ~ * ~ [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] ~ [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] END_OF_SOURCE } ); # Marpa::R2::Display::End my $show_rules_output = $grammar->show_rules(); $show_rules_output .= $grammar->show_rules(1, 'L0'); Marpa::R2::Test::is( $show_rules_output, <<'END_OF_SHOW_RULES_OUTPUT', 'Scanless show_rules()' ); G1 R0 Script ::= Expression + G1 R1 Expression ::= Expression G1 R2 Expression ::= Expression G1 R3 Expression ::= Expression G1 R4 Expression ::= Expression G1 R5 Expression ::= Number G1 R6 Expression ::= '(' Expression ')' G1 R7 Expression ::= Expression '**' Expression G1 R8 Expression ::= Expression '*' Expression G1 R9 Expression ::= Expression '/' Expression G1 R10 Expression ::= Expression '+' Expression G1 R11 Expression ::= Expression '-' Expression G1 R12 :start ::= Script L0 R0 comma ::= [,] L0 R1 '(' ::= [\(] L0 R2 ')' ::= [\)] L0 R3 '**' ::= [\*] [\*] L0 R4 '*' ::= [\*] L0 R5 '/' ::= [\/] L0 R6 '+' ::= [\+] L0 R7 '-' ::= [\-] L0 R8 Number ::= [\d] + L0 R9 :discard ::= whitespace L0 R10 whitespace ::= [\s] + L0 R11 :discard ::= L0 R12 ::= L0 R13 ::= L0 R14 ::= [\#] L0 R15 ::= [\#] L0 R16 ::= * L0 R17 ::= [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] L0 R18 ::= [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] L0 R19 :start_lex ::= Number L0 R20 :start_lex ::= :discard L0 R21 :start_lex ::= '(' L0 R22 :start_lex ::= ')' L0 R23 :start_lex ::= '**' L0 R24 :start_lex ::= '*' L0 R25 :start_lex ::= '/' L0 R26 :start_lex ::= '+' L0 R27 :start_lex ::= '-' L0 R28 :start_lex ::= comma END_OF_SHOW_RULES_OUTPUT sub my_parser { my ( $grammar, $p_input_string ) = @_; # Marpa::R2::Display # name: Scanless recognizer synopsis my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } ); my $self = bless { grammar => $grammar }, 'My_Actions'; $self->{recce} = $recce; if ( not defined eval { $recce->read($p_input_string); 1 } ) { ## Add last expression found, and rethrow my $eval_error = $EVAL_ERROR; chomp $eval_error; die $self->show_last_expression(), "\n", $eval_error, "\n"; } ## end if ( not defined eval { $event_count = $recce->read...}) my $value_ref = $recce->value( $self ); if ( not defined $value_ref ) { die $self->show_last_expression(), "\n", "No parse was found, after reading the entire input\n"; } # Marpa::R2::Display::End return ${$value_ref}; } ## end sub my_parser my @tests = ( [ '42*2+7/3, 42*(2+7)/3, 2**7-3, 2**(7-3)' => qr/\A 86[.]3\d+ \s+ 126 \s+ 125 \s+ 16\z/xms ], [ '42*3+7, 42 * 3 + 7, 42 * 3+7' => qr/ \s* 133 \s+ 133 \s+ 133 \s* /xms ], [ '15329 + 42 * 290 * 711, 42*3+7, 3*3+4* 4' => qr/ \s* 8675309 \s+ 133 \s+ 25 \s* /xms ], ); for my $test (@tests) { my ( $input, $output_re ) = @{$test}; my $value = my_parser( $grammar, \$input ); Test::More::like( $value, $output_re, 'Value of scannerless parse' ); } # Marpa::R2::Display # name: Scanless recognizer semantics package My_Actions; sub do_parens { shift; return $_[1] } sub do_add { shift; return $_[0] + $_[2] } sub do_subtract { shift; return $_[0] - $_[2] } sub do_multiply { shift; return $_[0] * $_[2] } sub do_divide { shift; return $_[0] / $_[2] } sub do_pow { shift; return $_[0]**$_[2] } sub do_first_arg { shift; return shift; } sub do_script { shift; return join q{ }, @_ } # Marpa::R2::Display::End # Marpa::R2::Display # name: Scanless recognizer diagnostics sub show_last_expression { my ($self) = @_; my $recce = $self->{recce}; my ( $g1_start, $g1_length ) = $recce->last_completed('Expression'); return 'No expression was successfully parsed' if not defined $g1_start; my $last_expression = $recce->substring( $g1_start, $g1_length ); return "Last expression successfully parsed was: $last_expression"; } ## end sub show_last_expression # Marpa::R2::Display::End # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 100 # End: # vim: expandtab shiftwidth=4: Marpa-R2-2.086000~dfsg/t/sl_diag.t0000444000000000000000000002644712342464707015110 0ustar rootroot#!perl # Copyright 2014 Jeffrey Kegler # This file is part of Marpa::R2. Marpa::R2 is free software: you can # redistribute it and/or modify it under the terms of the GNU Lesser # General Public License as published by the Free Software Foundation, # either version 3 of the License, or (at your option) any later version. # # Marpa::R2 is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser # General Public License along with Marpa::R2. If not, see # http://www.gnu.org/licenses/. # Test of scannerless parsing -- diagnostics use 5.010; use strict; use warnings; use Test::More tests => 12; use English qw( -no_match_vars ); use lib 'inc'; use Marpa::R2::Test; use Marpa::R2; my $grammar = <<'END_OF_RULES'; :start ::= Script Script ::= Calculation* action => do_list Calculation ::= Expression | ('say') Expression Expression ::= Number | ('+') Expression Expression action => do_add Number ~ [\d] + :discard ~ whitespace whitespace ~ [\s]+ # allow comments :discard ~ ~ | ~ '#' ~ '#' ~ * ~ [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] ~ [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}] END_OF_RULES my $slg = Marpa::R2::Scanless::G->new( { action_object => 'My_Actions', default_action => 'do_arg0', source => \$grammar, } ); my $g0_rules_description; # Marpa::R2::Display # name: Scanless g0_rule() synopsis my @g0_rule_ids = $slg->g0_rule_ids(); for my $g0_rule_id (@g0_rule_ids) { $g0_rules_description .= "$g0_rule_id " . ( join q{ }, map {"<$_>"} $slg->g0_rule($g0_rule_id) ) . "\n"; } # Marpa::R2::Display::End Marpa::R2::Test::is( $g0_rules_description, <<'END_OF_DESCRIPTION', 0 <[Lex-0]> <[[s]]> <[[a]]> <[[y]]> 1 <[Lex-1]> <[[\+]]> 2 <[[\d]]> 3 <[:discard]> 4 <[[\s]]> 5 <[:discard]> 6 7 8 <[[\#]]> 9 <[[\#]]> 10 11 <[[\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}]]> 12 <[[^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}]]> 13 <[:start_lex]> 14 <[:start_lex]> <[:discard]> 15 <[:start_lex]> <[Lex-0]> 16 <[:start_lex]> <[Lex-1]> END_OF_DESCRIPTION 'g0_rule_ids() and g0_rule()' ); my $g1_rules_description; # Marpa::R2::Display # name: Scanless rule() synopsis my @g1_rule_ids = $slg->g1_rule_ids(); for my $g1_rule_id (@g1_rule_ids) { $g1_rules_description .= "$g1_rule_id " . ( join q{ }, map {"<$_>"} $slg->rule($g1_rule_id) ) . "\n"; } # Marpa::R2::Display::End Marpa::R2::Test::is( $g1_rules_description, <<'END_OF_DESCRIPTION', 0