File Coverage

blib/lib/Marpa/R2/Stuifzand.pm
Criterion Covered Total %
statement 46 58 79.3
branch 7 16 43.7
condition 2 3 66.6
subroutine 7 7 100.0
pod n/a
total 62 84 73.8


line stmt bran cond sub pod time code
1             # Copyright 2022 Jeffrey Kegler
2             # This file is part of Marpa::R2. Marpa::R2 is free software: you can
3             # redistribute it and/or modify it under the terms of the GNU Lesser
4             # General Public License as published by the Free Software Foundation,
5             # either version 3 of the License, or (at your option) any later version.
6             #
7             # Marpa::R2 is distributed in the hope that it will be useful,
8             # but WITHOUT ANY WARRANTY; without even the implied warranty of
9             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
10             # Lesser General Public License for more details.
11             #
12             # You should have received a copy of the GNU Lesser
13             # General Public License along with Marpa::R2. If not, see
14             # http://www.gnu.org/licenses/.
15              
16             package Marpa::R2::Stuifzand;
17              
18 135     135   2709 use 5.010001;
  135         590  
19 135     135   872 use strict;
  135         377  
  135         3227  
20 135     135   752 use warnings;
  135         393  
  135         4166  
21              
22 135     135   820 use vars qw($VERSION $STRING_VERSION);
  135         410  
  135         10446  
23             $VERSION = '13.001_000';
24             $STRING_VERSION = $VERSION;
25             ## no critic(BuiltinFunctions::ProhibitStringyEval)
26             $VERSION = eval $VERSION;
27             ## use critic
28              
29             package Marpa::R2::Internal::Stuifzand;
30              
31 135     135   863 use English qw( -no_match_vars );
  135         348  
  135         854  
32              
33             # Internal names end in ']' and are distinguished by prefix.
34             #
35             # Suffixed with '[prec%d]' --
36             # a symbol created to implement precedence.
37             # Suffix is removed to restore 'original'.
38             #
39             # Prefixed with '[[' -- a character class
40             # These are their own 'original'.
41             #
42             # Prefixed with '[:' -- a reserved symbol, one which in the
43             # grammars start with a colon.
44             # These are their own 'original'.
45             #
46             # Of the form '[Lex-42]' - where for '42' any other
47             # decimal number can be subsituted. Anonymous lexicals.
48             # These symbols are their own originals.
49             #
50             # Prefixed with '[SYMBOL#' - a unnamed internal symbol.
51             # Seeing these
52             # indicates some sort of internal error. If seen,
53             # they will be treated as their own original.
54             #
55             # Suffixed with '[Sep]' indicates an internal version
56             # of a sequence separator. These are their own
57             # original, because otherwise the "original" name
58             # would conflict with the LHS of the sequence.
59             #
60              
61             my %node_status =
62             map { ; ($_ , q{} ) }
63             qw(
64             action
65             action_name
66             adverb_item
67             adverb_list
68             adverb_list_items
69             alternative
70             alternatives
71             array_descriptor
72             bare_name
73             blessing
74             blessing_name
75             boolean
76             bracketed_name
77             default_rule
78             empty_rule
79             group_association
80             left_association
81             lhs
82             op_declare
83             op_declare_bnf
84             parenthesized_rhs_primary_list
85             Perl_name
86             priorities
87             priority_rule
88             proper_specification
89             quantified_rule
90             quantifier
91             reserved_action_name
92             reserved_blessing_name
93             rhs
94             rhs_primary
95             rhs_primary_list
96             right_association
97             separator_specification
98             single_symbol
99             standard_name
100             start_rule
101             statement
102             statements
103             symbol
104             symbol_name
105             );
106              
107              
108             $node_status{'Marpa::R2::Internal::MetaAST'} = q{};
109             $node_status{array_descriptor} = "Actions in the form of array descriptors are not allowed";
110             $node_status{character_class} = "Character classes are not allowed";
111             $node_status{completion_event_declaration} = "Completion events are not allowed";
112             $node_status{discard_rule} = ":discard rules are not allowed";
113             $node_status{event_specification} = qq{The "event" adverb is not allowed};
114             $node_status{latm_specification} = qq{The "latm" adverb is not allowed};
115             $node_status{lexeme_default_statement} = "The lexeme default statement is not allowed";
116             $node_status{lexeme_rule} = "Lexeme statements are not allowed";
117             $node_status{nulled_event_declaration} = "Nulled events are not allowed";
118             $node_status{op_declare_match} = "lexical rules are not allowed";
119             $node_status{pause_specification} = "The pause adverb is not allowed";
120             $node_status{prediction_event_declaration} = "Prediction events are not allowed";
121             $node_status{priority_specification} = "The priority adverb is not allowed";
122             $node_status{single_quoted_string} = "Quoted strings are not allowed";
123             $node_status{alternative_name} = "Alternative naming is not allowed";
124             $node_status{naming} = "Alternative naming is not allowed";
125              
126             my %catch_error_node =
127             map { ; ($_ , 1 ) }
128             qw( alternative statement );
129              
130             # This code goes to some trouble to report errors with a large enough contet
131             # to be meaningful -- rules or alternatives
132              
133             sub Marpa::R2::Internal::Stuifzand::check_ast_node {
134 3639     3639   5148 my ($node) = @_;
135 3639         4922 my $ref_type = ref $node;
136 3639 100       6211 return if not $ref_type;
137 1139         2941 $ref_type =~ s/\A Marpa::R2::Internal::MetaAST_Nodes:: //xms;
138 1139         1629 my $report_error = 0;
139 1139         1805 my $problem = $node_status{$ref_type};
140 1139         1461 my $catch_error = $catch_error_node{$ref_type};
141 1139 50       1904 return qq{Internal error: Unknown AST node (type "$ref_type") in Stuifzand grammar}
142             if not defined $problem;
143             # "Normal" meaning other than catching errors
144             NORMAL_PROCESSING: {
145 1139 50       1373 if ($problem) {
  1139         1876  
146 0 0       0 return $problem if not $catch_error_node{$ref_type};
147 0         0 last NORMAL_PROCESSING;
148             }
149 1139         1376 for my $sub_node ( @{$node} ) {
  1139         2061  
150 3635         5176 $problem = Marpa::R2::Internal::Stuifzand::check_ast_node($sub_node);
151 3635 50       6506 if ($problem) {
152 0 0       0 return $problem if not $catch_error;
153 0         0 last NORMAL_PROCESSING;
154             }
155             } ## end for my $sub_node ( @{$node} )
156 1139         1770 return;
157             } ## end NORMAL_PROCESSING:
158              
159             # If we are here, we are catching an error
160 0         0 my ( $start, $end ) = @{$node};
  0         0  
161 0         0 my $problem_was_here = substr ${$Marpa::R2::Internal::P_SOURCE}, $start,
  0         0  
162             ($end-$start+1);
163 0         0 chomp $problem_was_here;
164 0         0 chomp $problem;
165 0         0 Marpa::R2::exception(
166             "Stuifzand (BNF) interface grammar is using a disallowed feature\n",
167             q{ } . $problem . "\n",
168             " Problem was in the following text:\n",
169             $problem_was_here,
170             "\n"
171             );
172             } ## end sub Marpa::R2::Internal::Stuifzand::check_ast_node
173              
174             sub parse_rules {
175 4     4   13 my ($p_rules_source) = @_;
176 4         7 my $self = {};
177 4         35 my $ast = Marpa::R2::Internal::MetaAST->new($p_rules_source);
178             {
179 4         10 local $Marpa::R2::Internal::P_SOURCE = $p_rules_source;
  4         11  
180             my $problem = Marpa::R2::Internal::Stuifzand::check_ast_node(
181 4         49 $ast->{top_node} );
182             ## Uncaught problem -- should not happen
183 4 50       29 if ($problem) {
184 0         0 Marpa::R2::exception(
185             "Stuifzand (BNF) interface grammar has a problem\n",
186             q{ } . $problem . "\n",
187             );
188             } ## end if ($problem)
189             }
190 4         38 my $hashed_ast = $ast->ast_to_hash();
191 4   66     29 my $start_lhs = $hashed_ast->{'start_lhs'} // $hashed_ast->{'first_lhs'};
192 4 50       44 Marpa::R2::exception( 'No rules in Stuifzand grammar', )
193             if not defined $start_lhs;
194              
195 4         16 my $internal_start_lhs = '[:start]';
196             $hashed_ast->{'default_g1_start_action'} =
197 4         35 $hashed_ast->{'default_adverbs'}->{'G1'}->{'action'};
198 4         26 $hashed_ast->{'symbols'}->{'G1'}->{$internal_start_lhs} = {
199             display_form => ':start',
200             description => 'Internal G1 start symbol'
201             };
202 4         11 push @{ $hashed_ast->{rules}->{G1} },
  4         24  
203             {
204             lhs => $internal_start_lhs,
205             rhs => [$start_lhs],
206             action => '::first'
207             };
208              
209 4         27 $self->{rules} = $hashed_ast->{rules}->{G1};
210 4         930 return $self;
211             } ## end sub parse_rules
212              
213             1;
214              
215             # vim: expandtab shiftwidth=4: