File Coverage

blib/lib/Marpa/R2/Value.pm
Criterion Covered Total %
statement 975 1237 78.8
branch 361 544 66.3
condition 85 130 65.3
subroutine 38 45 84.4
pod 0 12 0.0
total 1459 1968 74.1


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::Value;
17              
18 135     135   3040 use 5.010001;
  135         489  
19 135     135   799 use warnings;
  135         294  
  135         5019  
20 135     135   942 use strict;
  135         351  
  135         4603  
21              
22 135     135   832 use vars qw($VERSION $STRING_VERSION);
  135         338  
  135         12924  
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::Value;
30              
31 135     135   1090 use English qw( -no_match_vars );
  135         310  
  135         1042  
32              
33 135     135   51650 use constant SKIP => -1;
  135         339  
  135         66334  
34              
35             sub Marpa::R2::show_rank_ref {
36 0     0 0 0 my ($rank_ref) = @_;
37 0 0       0 return 'undef' if not defined $rank_ref;
38 0 0       0 return 'SKIP' if $rank_ref == Marpa::R2::Internal::Value::SKIP;
39 0         0 return ${$rank_ref};
  0         0  
40             } ## end sub Marpa::R2::show_rank_ref
41              
42             package Marpa::R2::Internal::Value;
43              
44             # Given the grammar and an action name, resolve it to a closure,
45             # or return undef
46             sub Marpa::R2::Internal::Recognizer::resolve_action {
47 30324     30324   47456 my ( $recce, $closure_name, $p_error ) = @_;
48 30324         41525 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
49 30324         39419 my $closures = $recce->[Marpa::R2::Internal::Recognizer::CLOSURES];
50 30324         39122 my $trace_actions =
51             $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS];
52              
53             # A reserved closure name;
54 30324 100       51535 return [ q{}, undef, '::!default' ] if not defined $closure_name;
55              
56 29315 50       48453 if ( $closure_name eq q{} ) {
57 0 0       0 ${$p_error} = q{The action string cannot be the empty string}
  0         0  
58             if defined $p_error;
59 0         0 return;
60             }
61              
62 29315 100       46732 return [ q{}, \undef, $closure_name ] if $closure_name eq '::undef';
63 29299 100 100     89321 if ( substr( $closure_name, 0, 2 ) eq q{::}
64             or substr( $closure_name, 0, 1 ) eq '[' )
65             {
66 24841         55345 return [ q{}, undef, $closure_name ];
67             }
68              
69 4458 100       10065 if ( my $closure = $closures->{$closure_name} ) {
70 2994 50       4715 if ($trace_actions) {
71 0 0       0 print {$Marpa::R2::Internal::TRACE_FH}
  0         0  
72             qq{Resolved "$closure_name" to explicit closure\n}
73             or Marpa::R2::exception('Could not print to trace file');
74             }
75              
76 2994         6892 return [ $closure_name, $closure, '::array' ];
77             } ## end if ( my $closure = $closures->{$closure_name} )
78              
79 1464         2042 my $fully_qualified_name;
80 1464 100       6538 if ( $closure_name =~ /([:][:])|[']/xms ) {
81 800         1405 $fully_qualified_name = $closure_name;
82             }
83              
84 1464 100       2866 if ( not $fully_qualified_name ) {
85 664         1127 my $resolve_package =
86             $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE];
87 664 50       1253 if ( not defined $resolve_package ) {
88 0         0 say STDERR
89             $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE];
90 0         0 say STDERR
91             $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE];
92 0         0 ${$p_error} = Marpa::R2::Internal::X->new(
  0         0  
93             { message =>
94             qq{Could not fully qualify "$closure_name": no resolve package},
95             name => 'NO RESOLVE PACKAGE'
96             }
97             );
98 0         0 return;
99             } ## end if ( not defined $resolve_package )
100 664         1542 $fully_qualified_name = $resolve_package . q{::} . $closure_name;
101             } ## end if ( not $fully_qualified_name )
102              
103 1464         2411 my $closure;
104             my $type;
105             TYPE: {
106 135     135   1115 no strict 'refs';
  135         325  
  135         7094  
  1464         1955  
107 1464         2014 $closure = *{$fully_qualified_name}{'CODE'};
  1464         4770  
108 135     135   951 use strict;
  135         378  
  135         6145  
109 1464 100       3362 if ( defined $closure ) {
110 1300         1884 $type = 'CODE';
111 1300         2093 last TYPE;
112             }
113 135     135   1032 no strict 'refs';
  135         366  
  135         6584  
114 164         236 $closure = *{$fully_qualified_name}{'SCALAR'};
  164         407  
115 135     135   929 use strict;
  135         304  
  135         17107  
116              
117             # Currently $closure is always defined, but this
118             # behavior is said to be subject to change in perlref
119 164 100 66     449 if ( defined $closure and defined ${$closure} ) {
  164         485  
120 35         66 $type = 'SCALAR';
121 35         56 last TYPE;
122             }
123              
124             # Re other symbol tables entries:
125             # We ignore ARRAY and HASH because they anything
126             # we resolve to is a potential array entry, something
127             # that not possible for arrays and hashes except
128             # indirectly, via references.
129             # FORMAT is deprecated.
130             # IO and GLOB seem too abstruse at the moment.
131              
132 129         249 $closure = undef;
133             } ## end TYPE:
134              
135 1464 100       2742 if ( defined $closure ) {
136 1335 50       2550 if ($trace_actions) {
137 0 0       0 print {$Marpa::R2::Internal::TRACE_FH}
  0         0  
138             qq{Successful resolution of action "$closure_name" as $type },
139             'to ', $fully_qualified_name, "\n"
140             or Marpa::R2::exception('Could not print to trace file');
141             } ## end if ($trace_actions)
142 1335         4038 return [ $fully_qualified_name, $closure, '::array' ];
143             } ## end if ( defined $closure )
144              
145 129 50 33     490 if ( $trace_actions or defined $p_error ) {
146 129         307 for my $slot (qw(ARRAY HASH IO FORMAT)) {
147 135     135   1046 no strict 'refs';
  135         338  
  135         1754889  
148 516 50       652 if ( defined *{$fully_qualified_name}{$slot} ) {
  516         1518  
149 0         0 my $error =
150             qq{Failed resolution of action "$closure_name" to $fully_qualified_name\n}
151             . qq{ $fully_qualified_name is present as a $slot, but a $slot is not an acceptable resolution\n};
152 0 0       0 if ($trace_actions) {
153 0 0       0 print {$Marpa::R2::Internal::TRACE_FH} $error
  0         0  
154             or
155             Marpa::R2::exception('Could not print to trace file');
156             }
157 0 0       0 ${$p_error} = $error if defined $p_error;
  0         0  
158 0         0 return;
159             } ## end if ( defined *{$fully_qualified_name}{$slot} )
160             } ## end for my $slot (qw(ARRAY HASH IO FORMAT))
161             } ## end if ( $trace_actions or defined $p_error )
162              
163             {
164 129         213 my $error =
  129         434  
165             qq{Failed resolution of action "$closure_name" to $fully_qualified_name\n};
166 129 50       388 ${$p_error} = $error if defined $p_error;
  129         222  
167 129 50       332 if ($trace_actions) {
168 0 0       0 print {$Marpa::R2::Internal::TRACE_FH} $error
  0         0  
169             or Marpa::R2::exception('Could not print to trace file');
170             }
171             }
172 129         359 return;
173              
174             } ## end sub Marpa::R2::Internal::Recognizer::resolve_action
175              
176             # Find the semantics for a lexeme.
177             sub Marpa::R2::Internal::Recognizer::lexeme_semantics_find {
178 41499     41499   59811 my ( $recce, $lexeme_id ) = @_;
179 41499         53226 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
180 41499         51477 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
181 41499         59970 my $symbol = $symbols->[$lexeme_id];
182 41499         59594 my $semantics = $symbol->[Marpa::R2::Internal::Symbol::LEXEME_SEMANTICS];
183 41499 100       83081 return '::!default' if not defined $semantics;
184 3959         6480 return $semantics;
185             } ## end sub Marpa::R2::Internal::Recognizer::lexeme_semantics_find
186              
187             # Find the blessing for a rule.
188             sub Marpa::R2::Internal::Recognizer::rule_blessing_find {
189 31364     31364   59215 my ( $recce, $rule_id ) = @_;
190 31364         42353 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
191 31364         39144 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
192 31364         39436 my $rule = $rules->[$rule_id];
193 31364         51318 my $blessing = $rule->[Marpa::R2::Internal::Rule::BLESSING];
194 31364 100       51932 $blessing = '::undef' if not defined $blessing;
195 31364 100       66200 return $blessing if $blessing eq '::undef';
196 22493         29989 my $bless_package =
197             $grammar->[Marpa::R2::Internal::Grammar::BLESS_PACKAGE];
198              
199 22493 50       36330 if ( not defined $bless_package ) {
200 0         0 Marpa::R2::exception(
201             qq{A blessed rule is in a grammar with no bless_package\n}
202             . qq{ The rule was blessed as "$blessing"\n} );
203             }
204 22493         62492 return join q{}, $bless_package, q{::}, $blessing;
205             } ## end sub Marpa::R2::Internal::Recognizer::rule_blessing_find
206              
207             # Find the blessing for a lexeme.
208             sub Marpa::R2::Internal::Recognizer::lexeme_blessing_find {
209 41499     41499   59543 my ( $recce, $lexeme_id ) = @_;
210 41499         52504 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
211 41499         50786 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
212 41499         51266 my $symbol = $symbols->[$lexeme_id];
213 41499         53620 my $blessing = $symbol->[Marpa::R2::Internal::Symbol::BLESSING];
214              
215 41499 100       81517 return '::undef' if not defined $blessing;
216 3710 50       6658 return '::undef' if $blessing eq '::undef';
217 3710 50       7117 if ( $blessing =~ m/\A [:][:] /xms ) {
218 0         0 my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER];
219 0         0 my $lexeme_name = $tracer->symbol_name($lexeme_id);
220 0         0 $recce->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE] =
221             qq{Symbol "$lexeme_name" has unknown blessing: "$blessing"};
222 0         0 return;
223             } ## end if ( $blessing =~ m/\A [:][:] /xms )
224 3710 50       6941 if ( $blessing =~ m/ [:][:] /xms ) {
225 0         0 return $blessing;
226             }
227 3710         5499 my $bless_package =
228             $grammar->[Marpa::R2::Internal::Grammar::BLESS_PACKAGE];
229 3710 50       6339 if ( not defined $bless_package ) {
230 0         0 my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER];
231 0         0 my $lexeme_name = $tracer->symbol_name($lexeme_id);
232 0         0 $recce->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE] =
233             qq{Symbol "$lexeme_name" needs a blessing package, but grammar has none\n}
234             . qq{ The blessing for "$lexeme_name" was "$blessing"\n};
235 0         0 return;
236             } ## end if ( not defined $bless_package )
237 3710         9739 return $bless_package . q{::} . $blessing;
238             } ## end sub Marpa::R2::Internal::Recognizer::lexeme_blessing_find
239              
240             # For diagnostics
241             sub Marpa::R2::Internal::Recognizer::brief_rule_list {
242 0     0   0 my ( $recce, $rule_ids ) = @_;
243 0         0 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
244 0         0 my @brief_rules = map { $grammar->brief_rule($_) } @{$rule_ids};
  0         0  
  0         0  
245 0         0 return join q{}, map { q{ } . $_ . "\n" } @brief_rules;
  0         0  
246             } ## end sub Marpa::R2::Internal::Recognizer::brief_rule_list
247              
248             our $CONTEXT_EXCEPTION_CLASS = __PACKAGE__ . '::Context_Exception';
249              
250             sub Marpa::R2::Context::bail { ## no critic (Subroutines::RequireArgUnpacking)
251 4 100 66 4   62 if ( scalar @_ == 1 and ref $_[0] ) {
252 2         22 die bless { exception_object => $_[0] }, $CONTEXT_EXCEPTION_CLASS;
253             }
254 2         12 my $error_string = join q{}, @_;
255 2         10 my ( $package, $filename, $line ) = caller;
256 2         7 chomp $error_string;
257 2         50 die bless { message => qq{User bailed at line $line in file "$filename"\n}
258             . $error_string
259             . "\n" }, $CONTEXT_EXCEPTION_CLASS;
260             } ## end sub Marpa::R2::Context::bail
261             ## use critic
262              
263             sub Marpa::R2::Context::location {
264 2     2   29 my $valuator = $Marpa::R2::Internal::Context::VALUATOR;
265 2 50       7 Marpa::R2::exception(
266             'Marpa::R2::Context::location called outside of a valuation context')
267             if not defined $valuator;
268 2         20 return $valuator->location();
269             } ## end sub Marpa::R2::Context::location
270              
271             sub code_problems {
272 10     10   26 my $args = shift;
273              
274 10         19 my $grammar;
275             my $fatal_error;
276 10         18 my $warnings = [];
277 10         18 my $where = '?where?';
278 10         15 my $long_where;
279 10         18 my @msg = ();
280 10         15 my $eval_value;
281 10         16 my $eval_given = 0;
282              
283 10         23 push @msg, q{=} x 60, "\n";
284 10         17 ARG: for my $arg ( keys %{$args} ) {
  10         38  
285 60         93 my $value = $args->{$arg};
286 60 100       137 if ( $arg eq 'fatal_error' ) { $fatal_error = $value; next ARG }
  10         19  
  10         18  
287 50 100       93 if ( $arg eq 'grammar' ) { $grammar = $value; next ARG }
  10         14  
  10         23  
288 40 100       71 if ( $arg eq 'where' ) { $where = $value; next ARG }
  10         18  
  10         15  
289 30 100       55 if ( $arg eq 'long_where' ) { $long_where = $value; next ARG }
  10         15  
  10         19  
290 20 100       41 if ( $arg eq 'warnings' ) { $warnings = $value; next ARG }
  10         27  
  10         21  
291 10 50       29 if ( $arg eq 'eval_ok' ) {
292 10         16 $eval_value = $value;
293 10         14 $eval_given = 1;
294 10         20 next ARG;
295             }
296 0         0 push @msg, "Unknown argument to code_problems: $arg";
297             } ## end ARG: for my $arg ( keys %{$args} )
298              
299             GIVEN_FATAL_ERROR_REF_TYPE: {
300 10         22 my $fatal_error_ref_type = ref $fatal_error;
  10         23  
301 10 100       24 last GIVEN_FATAL_ERROR_REF_TYPE if not $fatal_error_ref_type;
302 4 50       13 if ( $fatal_error_ref_type eq $CONTEXT_EXCEPTION_CLASS ) {
303 4         7 my $exception_object = $fatal_error->{exception_object};
304 4 100       70 die $exception_object if defined $exception_object;
305 2         6 my $exception_message = $fatal_error->{message};
306 2 50       64 die $exception_message if defined $exception_message;
307 0         0 die "Internal error: bad $CONTEXT_EXCEPTION_CLASS object";
308             } ## end if ( $fatal_error_ref_type eq $CONTEXT_EXCEPTION_CLASS)
309             $fatal_error =
310 0         0 "Exception thrown as object inside Marpa closure\n"
311             . ( q{ } x 4 )
312             . "This is not allowed\n"
313             . ( q{ } x 4 )
314             . qq{Exception as string is "$fatal_error"};
315             } ## end GIVEN_FATAL_ERROR_REF_TYPE:
316              
317 6         13 my @problem_line = ();
318 6         8 my $max_problem_line = -1;
319 6         7 for my $warning_data ( @{$warnings} ) {
  6         13  
320             my ( $warning, $package, $filename, $problem_line ) =
321 4         7 @{$warning_data};
  4         8  
322 4         9 $problem_line[$problem_line] = 1;
323 4         12 $max_problem_line = List::Util::max $problem_line, $max_problem_line;
324             } ## end for my $warning_data ( @{$warnings} )
325              
326 6   33     15 $long_where //= $where;
327              
328 6         10 my $warnings_count = scalar @{$warnings};
  6         10  
329             {
330 6         9 my @problems;
  6         8  
331 6   66     40 my $false_eval = $eval_given && !$eval_value && !$fatal_error;
332 6 50       12 if ($false_eval) {
333 0         0 push @problems, '* THE MARPA SEMANTICS RETURNED A PERL FALSE',
334             'Marpa::R2 requires its semantics to return a true value';
335             }
336 6 100       13 if ($fatal_error) {
337 4         6 push @problems, '* THE MARPA SEMANTICS PRODUCED A FATAL ERROR';
338             }
339 6 100       12 if ($warnings_count) {
340 2         7 push @problems,
341             "* THERE WERE $warnings_count WARNING(S) IN THE MARPA SEMANTICS:",
342             'Marpa treats warnings as fatal errors';
343             }
344 6 50       14 if ( not scalar @problems ) {
345 0         0 push @msg, '* THERE WAS A FATAL PROBLEM IN THE MARPA SEMANTICS';
346             }
347 6         19 push @msg, ( join "\n", @problems ) . "\n";
348             }
349              
350 6         14 push @msg, "* THIS IS WHAT MARPA WAS DOING WHEN THE PROBLEM OCCURRED:\n"
351             . $long_where . "\n";
352              
353 6         14 for my $warning_ix ( 0 .. ( $warnings_count - 1 ) ) {
354 4         11 push @msg, "* WARNING MESSAGE NUMBER $warning_ix:\n";
355 4         7 my $warning_message = $warnings->[$warning_ix]->[0];
356 4         39 $warning_message =~ s/\n*\z/\n/xms;
357 4         12 push @msg, $warning_message;
358             } ## end for my $warning_ix ( 0 .. ( $warnings_count - 1 ) )
359              
360 6 100       12 if ($fatal_error) {
361 4         8 push @msg, "* THIS WAS THE FATAL ERROR MESSAGE:\n";
362 4         8 my $fatal_error_message = $fatal_error;
363 4         46 $fatal_error_message =~ s/\n*\z/\n/xms;
364 4         9 push @msg, $fatal_error_message;
365             } ## end if ($fatal_error)
366              
367 6         23 Marpa::R2::exception(@msg);
368              
369             # this is to keep perlcritic happy
370 0         0 return 1;
371              
372             } ## end sub code_problems
373              
374             # Dump semantics for diagnostics
375             sub show_semantics {
376 0     0   0 my (@ops) = @_;
377 0         0 my @op_descs = ();
378 0         0 my $op_ix = 0;
379 0         0 OP: while ( $op_ix < scalar @ops ) {
380 0         0 my $op = $ops[ $op_ix++ ];
381 0         0 my $op_name = Marpa::R2::Thin::op_name($op);
382 0         0 push @op_descs, $op_name;
383 0 0       0 if ( $op_name eq 'bless' ) {
384 0         0 push @op_descs, q{"} . $ops[$op_ix] . q{"};
385 0         0 $op_ix++;
386 0         0 next OP;
387             }
388 0 0       0 if ( $op_name eq 'push_constant' ) {
389 0         0 push @op_descs, $ops[$op_ix];
390 0         0 $op_ix++;
391 0         0 next OP;
392             }
393 0 0       0 if ( $op_name eq 'push_one' ) {
394 0         0 push @op_descs, $ops[$op_ix];
395 0         0 $op_ix++;
396 0         0 next OP;
397             }
398 0 0       0 if ( $op_name eq 'result_is_rhs_n' ) {
399 0         0 push @op_descs, $ops[$op_ix];
400 0         0 $op_ix++;
401 0         0 next OP;
402             }
403 0 0       0 if ( $op_name eq 'result_is_n_of_sequence' ) {
404 0         0 push @op_descs, $ops[$op_ix];
405 0         0 $op_ix++;
406 0         0 next OP;
407             }
408 0 0       0 if ( $op_name eq 'result_is_constant' ) {
409 0         0 push @op_descs, $ops[$op_ix];
410 0         0 $op_ix++;
411 0         0 next OP;
412             }
413 0 0       0 if ( $op_name eq 'alternative' ) {
414 0         0 push @op_descs, $ops[$op_ix];
415 0         0 $op_ix++;
416 0         0 push @op_descs, $ops[$op_ix];
417 0         0 $op_ix++;
418 0         0 next OP;
419             } ## end if ( $op_name eq 'alternative' )
420             } ## end OP: while ( $op_ix < scalar @ops )
421 0         0 return join q{ }, @op_descs;
422             } ## end sub show_semantics
423              
424             # Return false if no ordering was created,
425             # otherwise return the ordering.
426             sub Marpa::R2::Recognizer::ordering_get {
427 1410     1410 0 2846 my ($recce) = @_;
428 1410 50       3410 return if $recce->[Marpa::R2::Internal::Recognizer::NO_PARSE];
429 1410         2368 my $ordering = $recce->[Marpa::R2::Internal::Recognizer::O_C];
430 1410 100       3630 return $ordering if $ordering;
431 1188         1873 my $parse_set_arg =
432             $recce->[Marpa::R2::Internal::Recognizer::END_OF_PARSE];
433 1188         1913 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
434 1188         1894 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
435 1188         1872 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
436              
437 1188         3851 $grammar_c->throw_set(0);
438 1188   100     53212 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C] =
439             Marpa::R2::Thin::B->new( $recce_c, ( $parse_set_arg // -1 ) );
440 1188         4484 $grammar_c->throw_set(1);
441 1188 100       3898 if ( not $bocage ) {
442 20         43 $recce->[Marpa::R2::Internal::Recognizer::NO_PARSE] = 1;
443 20         48 return;
444             }
445 1168         5206 $ordering = $recce->[Marpa::R2::Internal::Recognizer::O_C] =
446             Marpa::R2::Thin::O->new($bocage);
447              
448             GIVEN_RANKING_METHOD: {
449 1168         2090 my $ranking_method =
  1168         2171  
450             $recce->[Marpa::R2::Internal::Recognizer::RANKING_METHOD];
451 1168 100       3056 if ( $ranking_method eq 'high_rule_only' ) {
452 95         313 do_high_rule_only($recce);
453 95         202 last GIVEN_RANKING_METHOD;
454             }
455 1073 100       3009 if ( $ranking_method eq 'rule' ) {
456 8         45 do_rank_by_rule($recce);
457 8         19 last GIVEN_RANKING_METHOD;
458             }
459             } ## end GIVEN_RANKING_METHOD:
460              
461 1168         3045 return $ordering;
462             } ## end sub Marpa::R2::Recognizer::ordering_get
463              
464             sub resolve_rule_by_id {
465 31365     31365   46373 my ( $recce, $rule_id ) = @_;
466 31365         41930 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
467 31365         39444 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
468 31365         45284 my $rule = $rules->[$rule_id];
469 31365         59987 my $action_name = $rule->[Marpa::R2::Internal::Rule::ACTION_NAME];
470 31365         38159 my $resolve_error;
471 31365 100       53313 return if not defined $action_name;
472 28957         46286 my $resolution = Marpa::R2::Internal::Recognizer::resolve_action( $recce,
473             $action_name, \$resolve_error );
474              
475 28957 100       54036 if ( not $resolution ) {
476 1         4 my $rule_desc = rule_describe( $grammar, $rule_id );
477 1   50     12 Marpa::R2::exception(
478             "Could not resolve rule action named '$action_name'\n",
479             " Rule was $rule_desc\n",
480             q{ },
481             ( $resolve_error // 'Failed to resolve action' )
482             );
483             } ## end if ( not $resolution )
484 28956         46296 return $resolution;
485             } ## end sub resolve_rule_by_id
486              
487             # For error messages -- checks if it is called in context with
488             # SLR defined
489             sub rule_describe {
490 1     1   3 my ( $grammar, $rule_id ) = @_;
491 1 50       7 return $Marpa::R2::Context::slr->rule_show($rule_id)
492             if $Marpa::R2::Context::slr;
493 0         0 return $grammar->rule_describe($rule_id);
494             } ## end sub rule_describe
495              
496             sub resolve_recce {
497              
498 1168     1168   2330 my ( $recce, $per_parse_arg ) = @_;
499 1168         2065 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
500 1168         1996 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
501 1168         1849 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
502 1168         1961 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
503              
504 1168   50     3636 my $trace_actions =
505             $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0;
506 1168         2632 my $trace_file_handle =
507             $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE];
508              
509 1168         2027 my $package_source =
510             $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE];
511 1168 100 100     5017 if ( not defined $package_source
      66        
512             and defined $per_parse_arg
513             and ( my $arg_blessing = Scalar::Util::blessed $per_parse_arg) )
514             {
515 80         181 $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE] =
516             $arg_blessing;
517 80         141 $package_source = 'arg';
518             } ## end if ( not defined $package_source and defined $per_parse_arg...)
519 1168   100     4004 $package_source //= 'semantics_package';
520 1168         2186 $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE] =
521             $package_source;
522              
523 1168 100       2822 if ( $package_source eq 'legacy' ) {
524              
525             # RESOLVE_PACKAGE is already set if not 'legacy'
526 237   100     914 $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE] =
527             $grammar->[Marpa::R2::Internal::Grammar::ACTIONS]
528             // $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT];
529             } ## end if ( $package_source eq 'legacy' )
530              
531             FIND_CONSTRUCTOR: {
532 1168 100       1799 my $constructor_package =
  1168         2988  
533             ( $package_source eq 'legacy' )
534             ? $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT]
535             : $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE];
536 1168 100       3490 last FIND_CONSTRUCTOR if not defined $constructor_package;
537 189         562 my $constructor_name = $constructor_package . q{::new};
538 189         324 my $resolve_error;
539 189         592 my $resolution =
540             Marpa::R2::Internal::Recognizer::resolve_action( $recce,
541             $constructor_name, \$resolve_error );
542 189 100       496 if ($resolution) {
543 61         133 $recce->[ Marpa::R2::Internal::Recognizer::PER_PARSE_CONSTRUCTOR ]
544             = $resolution->[1];
545 61         177 last FIND_CONSTRUCTOR;
546             }
547 128 50       418 last FIND_CONSTRUCTOR if $package_source ne 'legacy';
548 0   0     0 Marpa::R2::exception(
549             qq{Could not find constructor "$constructor_name"},
550             q{ }, ( $resolve_error // 'Failed to resolve action' ) );
551             } ## end FIND_CONSTRUCTOR:
552              
553 1168         1820 my $resolve_error;
554              
555 1168         2090 my $default_action =
556             $grammar->[Marpa::R2::Internal::Grammar::DEFAULT_ACTION];
557 1168         3393 my $default_action_resolution =
558             Marpa::R2::Internal::Recognizer::resolve_action( $recce,
559             $default_action, \$resolve_error );
560 1168 50 0     3090 Marpa::R2::exception(
561             "Could not resolve default action named '$default_action'\n",
562             q{ }, ( $resolve_error // 'Failed to resolve action' ) )
563             if not $default_action_resolution;
564              
565 1168         2053 my $default_empty_action =
566             $grammar->[Marpa::R2::Internal::Grammar::DEFAULT_EMPTY_ACTION];
567 1168         1744 my $default_empty_action_resolution;
568 1168 100       2596 if ($default_empty_action) {
569 10         27 $default_empty_action_resolution =
570             Marpa::R2::Internal::Recognizer::resolve_action( $recce,
571             $default_empty_action, \$resolve_error );
572 10 50 0     29 Marpa::R2::exception(
573             "Could not resolve default empty rule action named '$default_empty_action'",
574             q{ },
575             ( $resolve_error // 'Failed to resolve action' )
576             ) if not $default_empty_action_resolution;
577             } ## end if ($default_empty_action)
578              
579 1168         2110 my $rule_resolutions = [];
580              
581 1168         4520 RULE: for my $rule_id ( $grammar->rule_ids() ) {
582              
583 31365         49492 my $rule_resolution = resolve_rule_by_id( $recce, $rule_id );
584 31364 100 100     62730 if ( not defined $rule_resolution
      100        
585             and $default_empty_action
586             and $grammar_c->rule_length($rule_id) == 0 )
587             {
588 13         24 $rule_resolution = $default_empty_action_resolution;
589             } ## end if ( not defined $rule_resolution and $default_empty_action...)
590              
591 31364   66     55341 $rule_resolution //= $default_action_resolution;
592              
593 31364 50       49611 if ( not $rule_resolution ) {
594 0         0 my $rule_desc = rule_describe( $grammar, $rule_id );
595 0         0 my $message = "Could not resolve action\n Rule was $rule_desc\n";
596              
597 0         0 my $rule = $rules->[$rule_id];
598 0         0 my $action = $rule->[Marpa::R2::Internal::Rule::ACTION_NAME];
599 0 0       0 $message .= qq{ Action was specified as "$action"\n}
600             if defined $action;
601 0         0 my $recce_error =
602             $recce->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE];
603 0 0       0 $message .= q{ } . $recce_error if defined $recce_error;
604 0         0 Marpa::R2::exception($message);
605             } ## end if ( not $rule_resolution )
606              
607             DETERMINE_BLESSING: {
608              
609 31364         38757 my $blessing =
  31364         48061  
610             Marpa::R2::Internal::Recognizer::rule_blessing_find( $recce,
611             $rule_id );
612 31364         44150 my ( $closure_name, $closure, $semantics ) = @{$rule_resolution};
  31364         52697  
613              
614 31364 100       57434 if ( $blessing ne '::undef' ) {
615 22493 50       37479 $semantics = '::array' if $semantics eq '::!default';
616             CHECK_SEMANTICS: {
617 22493 100       27691 last CHECK_SEMANTICS if $semantics eq '::array';
  22493         36676  
618             last CHECK_SEMANTICS
619 22399 50       43249 if ( substr $semantics, 0, 1 ) eq '[';
620 0         0 Marpa::R2::exception(
621             qq{Attempt to bless, but improper semantics: "$semantics"}
622             );
623             } ## end CHECK_SEMANTICS:
624             } ## end if ( $blessing ne '::undef' )
625              
626             $rule_resolution =
627 31364         76464 [ $closure_name, $closure, $semantics, $blessing ];
628             } ## end DETERMINE_BLESSING:
629              
630 31364         57847 $rule_resolutions->[$rule_id] = $rule_resolution;
631              
632             } ## end RULE: for my $rule_id ( $grammar->rule_ids() )
633              
634 1167 50       4084 if ( $trace_actions >= 2 ) {
635 0         0 RULE: for my $rule_id ( 0 .. $#{$rules} ) {
  0         0  
636             my ( $resolution_name, $closure ) =
637 0         0 @{ $rule_resolutions->[$rule_id] };
  0         0  
638 0 0       0 say {$trace_file_handle} 'Rule ',
  0         0  
639             $grammar->brief_rule($rule_id),
640             qq{ resolves to "$resolution_name"}
641             or Marpa::R2::exception('print to trace handle failed');
642             } ## end RULE: for my $rule_id ( 0 .. $#{$rules} )
643             } ## end if ( $trace_actions >= 2 )
644              
645 1167         2370 my @lexeme_resolutions = ();
646 1167         1988 SYMBOL: for my $lexeme_id ( 0 .. $#{$symbols} ) {
  1167         4180  
647 41499         59952 my $semantics =
648             Marpa::R2::Internal::Recognizer::lexeme_semantics_find( $recce,
649             $lexeme_id );
650 41499 50       69410 if ( not defined $semantics ) {
651 0         0 my $message =
652             "Could not determine lexeme's semantics\n"
653             . q{ Lexeme was }
654             . $grammar->symbol_name($lexeme_id) . "\n";
655 0         0 $message
656             .= q{ }
657             . $recce->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE];
658 0         0 Marpa::R2::exception($message);
659             } ## end if ( not defined $semantics )
660 41499         58262 my $blessing =
661             Marpa::R2::Internal::Recognizer::lexeme_blessing_find( $recce,
662             $lexeme_id );
663 41499 50       69752 if ( not defined $blessing ) {
664 0         0 my $message =
665             "Could not determine lexeme's blessing\n"
666             . q{ Lexeme was }
667             . $grammar->symbol_name($lexeme_id) . "\n";
668 0         0 $message
669             .= q{ }
670             . $recce->[Marpa::R2::Internal::Recognizer::ERROR_MESSAGE];
671 0         0 Marpa::R2::exception($message);
672             } ## end if ( not defined $blessing )
673 41499         88139 $lexeme_resolutions[$lexeme_id] = [ $semantics, $blessing ];
674              
675             } ## end SYMBOL: for my $lexeme_id ( 0 .. $#{$symbols} )
676              
677 1167         5864 return ( $rule_resolutions, \@lexeme_resolutions );
678             } ## end sub resolve_recce
679              
680             sub registration_init {
681 1119     1119   2648 my ( $recce, $per_parse_arg ) = @_;
682              
683 1119         2869 my $trace_file_handle =
684             $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE];
685 1119         1956 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
686 1119         1937 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
687 1119         1784 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
688 1119         1824 my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER];
689 1119   50     3984 my $trace_actions =
690             $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0;
691 1119         1903 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
692 1119         1832 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
693              
694 1119         2097 my @closure_by_rule_id = ();
695 1119         1712 my @semantics_by_rule_id = ();
696 1119         1750 my @blessing_by_rule_id = ();
697              
698 1119         2865 my ( $rule_resolutions, $lexeme_resolutions ) =
699             resolve_recce( $recce, $per_parse_arg );
700              
701             # Set the arrays, and perform various checks on the resolutions
702             # we received
703             {
704             # ::whatever is deprecated and has been removed from the docs
705             # it is now equivalent to ::undef
706              
707 1118         2065 RULE:
708 1118         3957 for my $rule_id ( $grammar->rule_ids() ) {
709             my ( $new_resolution, $closure, $semantics, $blessing ) =
710 30996         38680 @{ $rule_resolutions->[$rule_id] };
  30996         61493  
711 30996         64097 my $lhs_id = $grammar_c->rule_lhs($rule_id);
712              
713             REFINE_SEMANTICS: {
714              
715 30996 100 66     40966 if ('[' eq substr $semantics,
  30996         85005  
716             0, 1 and ']' eq substr $semantics,
717             -1, 1
718             )
719             {
720             # Normalize array semantics
721 22974         214546 $semantics =~ s/ //gxms;
722 22974         36683 last REFINE_SEMANTICS;
723             } ## end if ( '[' eq substr $semantics, 0, 1 and ']' eq ...)
724              
725             state $allowed_semantics = {
726 8022         10540 map { ; ( $_, 1 ) }
  702         2474  
727             qw(::array ::undef ::first ::whatever ::!default),
728             q{}
729             };
730 8022 50       16268 last REFINE_SEMANTICS if $allowed_semantics->{$semantics};
731             last REFINE_SEMANTICS
732 0 0       0 if $semantics =~ m/ \A rhs \d+ \z /xms;
733              
734 0         0 Marpa::R2::exception(
735             q{Unknown semantics for rule },
736             $grammar->brief_rule($rule_id),
737             "\n",
738             qq{ Semantics were specified as "$semantics"\n}
739             );
740              
741             } ## end REFINE_SEMANTICS:
742              
743 30996         48735 $semantics_by_rule_id[$rule_id] = $semantics;
744 30996         41880 $blessing_by_rule_id[$rule_id] = $blessing;
745 30996         41686 $closure_by_rule_id[$rule_id] = $closure;
746              
747             CHECK_BLESSING: {
748 30996 100       36514 last CHECK_BLESSING if $blessing eq '::undef';
  30996         56304  
749 22373 50       34532 if ($closure) {
750 0         0 my $ref_type = Scalar::Util::reftype $closure;
751 0 0       0 if ( $ref_type eq 'SCALAR' ) {
752              
753             # The constant's dump might be long so I repeat the error message
754 0         0 Marpa::R2::exception(
755             qq{Fatal error: Attempt to bless a rule that resolves to a scalar constant\n},
756             qq{ Scalar constant is },
757             Data::Dumper::Dumper($closure),
758             qq{ Blessing is "$blessing"\n},
759             q{ Rule is: },
760             $grammar->brief_rule($rule_id),
761             "\n",
762             qq{ Cannot bless rule when it resolves to a scalar constant},
763             "\n",
764             );
765             } ## end if ( $ref_type eq 'SCALAR' )
766 0         0 last CHECK_BLESSING;
767             } ## end if ($closure)
768 22373 100       35271 last CHECK_BLESSING if $semantics eq '::array';
769 22279 50       48368 last CHECK_BLESSING if ( substr $semantics, 0, 1 ) eq '[';
770 0         0 Marpa::R2::exception(
771             qq{Cannot bless rule when the semantics are "$semantics"},
772             q{ Rule is: },
773             $grammar->brief_rule($rule_id),
774             "\n",
775             qq{ Blessing is "$blessing"\n},
776             qq{ Semantics are "$semantics"\n}
777             );
778             } ## end CHECK_BLESSING:
779              
780             } ## end RULE: for my $rule_id ( $grammar->rule_ids() )
781              
782             } ## end CHECK_FOR_WHATEVER_CONFLICT
783              
784             # A LHS can be nullable via more than one rule,
785             # and that means more than one semantics might be specified for
786             # the nullable symbol. This logic deals with that.
787 1118         3220 my @nullable_rule_ids_by_lhs = ();
788 1118         3439 RULE: for my $rule_id ( $grammar->rule_ids() ) {
789 30996         47945 my $lhs_id = $grammar_c->rule_lhs($rule_id);
790 30996 100       64425 push @{ $nullable_rule_ids_by_lhs[$lhs_id] }, $rule_id
  2122         5810  
791             if $grammar_c->rule_is_nullable($rule_id);
792             }
793              
794 1118         2679 my @null_symbol_closures;
795             LHS:
796 1118         3597 for ( my $lhs_id = 0; $lhs_id <= $#nullable_rule_ids_by_lhs; $lhs_id++ ) {
797 31648         39742 my $rule_ids = $nullable_rule_ids_by_lhs[$lhs_id];
798 31648         36469 my $resolution_rule;
799              
800             # No nullable rules for this LHS? No problem.
801 31648 100       64442 next LHS if not defined $rule_ids;
802 2112         3089 my $rule_count = scalar @{$rule_ids};
  2112         3529  
803              
804             # I am not sure if this test is necessary
805 2112 50       4237 next LHS if $rule_count <= 0;
806              
807             # Just one nullable rule? Then that's our semantics.
808 2112 100       4025 if ( $rule_count == 1 ) {
809 2102         3057 $resolution_rule = $rule_ids->[0];
810             my ( $resolution_name, $closure ) =
811 2102         2835 @{ $rule_resolutions->[$resolution_rule] };
  2102         4070  
812 2102 50       3954 if ($trace_actions) {
813 0         0 my $lhs_name = $grammar->symbol_name($lhs_id);
814 0 0       0 say {$trace_file_handle}
  0         0  
815             qq{Nulled symbol "$lhs_name" },
816             qq{ resolved to "$resolution_name" from rule },
817             $grammar->brief_rule($resolution_rule)
818             or Marpa::R2::exception('print to trace handle failed');
819             } ## end if ($trace_actions)
820 2102         4236 $null_symbol_closures[$lhs_id] = $resolution_rule;
821 2102         5141 next LHS;
822             } ## end if ( $rule_count == 1 )
823              
824             # More than one rule? Are any empty?
825             # If so, use the semantics of the empty rule
826             my @empty_rules =
827 10         28 grep { $grammar_c->rule_length($_) <= 0 } @{$rule_ids};
  20         80  
  10         27  
828 10 100       44 if ( scalar @empty_rules ) {
829 9         19 $resolution_rule = $empty_rules[0];
830             my ( $resolution_name, $closure ) =
831 9         14 @{ $rule_resolutions->[$resolution_rule] };
  9         23  
832 9 50       26 if ($trace_actions) {
833 0         0 my $lhs_name = $grammar->symbol_name($lhs_id);
834 0 0       0 say {$trace_file_handle}
  0         0  
835             qq{Nulled symbol "$lhs_name" },
836             qq{ resolved to "$resolution_name" from rule },
837             $grammar->brief_rule($resolution_rule)
838             or Marpa::R2::exception('print to trace handle failed');
839             } ## end if ($trace_actions)
840 9         27 $null_symbol_closures[$lhs_id] = $resolution_rule;
841 9         29 next LHS;
842             } ## end if ( scalar @empty_rules )
843              
844             # Multiple rules, none of them empty.
845             my ( $first_resolution, @other_resolutions ) =
846 1         3 map { $rule_resolutions->[$_] } @{$rule_ids};
  2         7  
  1         2  
847              
848             # Do they have more than one semantics?
849             # If so, just call it an error and let the user sort it out.
850             my ( $first_closure_name, undef, $first_semantics, $first_blessing )
851 1         3 = @{$first_resolution};
  1         3  
852 1         4 OTHER_RESOLUTION: for my $other_resolution (@other_resolutions) {
853             my ( $other_closure_name, undef, $other_semantics,
854             $other_blessing )
855 1         2 = @{$other_resolution};
  1         3  
856              
857 1 50 33     11 if ( $first_closure_name ne $other_closure_name
      33        
858             or $first_semantics ne $other_semantics
859             or $first_blessing ne $other_blessing )
860             {
861 0         0 Marpa::R2::exception(
862             'When nulled, symbol ',
863             $grammar->symbol_name($lhs_id),
864             qq{ can have more than one semantics\n},
865             qq{ Marpa needs there to be only one semantics\n},
866             qq{ The rules involved are:\n},
867             Marpa::R2::Internal::Recognizer::brief_rule_list(
868             $recce, $rule_ids
869             )
870             );
871             } ## end if ( $first_closure_name ne $other_closure_name or ...)
872             } ## end OTHER_RESOLUTION: for my $other_resolution (@other_resolutions)
873              
874             # Multiple rules, but they all have one semantics.
875             # So (obviously) use that semantics
876 1         4 $resolution_rule = $rule_ids->[0];
877             my ( $resolution_name, $closure ) =
878 1         2 @{ $rule_resolutions->[$resolution_rule] };
  1         6  
879 1 50       4 if ($trace_actions) {
880 0         0 my $lhs_name = $grammar->symbol_name($lhs_id);
881 0 0       0 say {$trace_file_handle}
  0         0  
882             qq{Nulled symbol "$lhs_name" },
883             qq{ resolved to "$resolution_name" from rule },
884             $grammar->brief_rule($resolution_rule)
885             or Marpa::R2::exception('print to trace handle failed');
886             } ## end if ($trace_actions)
887 1         4 $null_symbol_closures[$lhs_id] = $resolution_rule;
888              
889             } ## end LHS: for ( my $lhs_id = 0; $lhs_id <= $#nullable_rule_ids_by_lhs...)
890              
891             # Do consistency checks
892              
893             # Set the object values
894 1118         2703 $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES] =
895             \@null_symbol_closures;
896              
897 1118         2135 my @semantics_by_lexeme_id = ();
898 1118         1863 my @blessing_by_lexeme_id = ();
899              
900             # Check the lexeme semantics
901             {
902             # ::whatever is deprecated and has been removed from the docs
903             # it is now equivalent to ::undef
904 1118         1683 LEXEME: for my $lexeme_id ( 0 .. $#{$symbols} ) {
  1118         1721  
  1118         2853  
905              
906             my ( $semantics, $blessing ) =
907 41075         48959 @{ $lexeme_resolutions->[$lexeme_id] };
  41075         67456  
908             CHECK_SEMANTICS: {
909 41075 50       51765 if ( not $semantics ) {
  41075         64078  
910 0         0 $semantics = '::!default';
911 0         0 last CHECK_SEMANTICS;
912             }
913 41075 100       72472 if ( ( substr $semantics, 0, 1 ) eq '[' ) {
914 3933         37624 $semantics =~ s/ //gxms;
915 3933         6403 last CHECK_SEMANTICS;
916             }
917             state $allowed_semantics =
918 37142         43611 { map { ; ( $_, 1 ) } qw(::array ::undef ::!default ) };
  351         1051  
919              
920 37142 50       64709 if ( not $allowed_semantics->{$semantics} ) {
921 0         0 Marpa::R2::exception(
922             q{Unknown semantics for lexeme },
923             $grammar->symbol_name($lexeme_id),
924             "\n",
925             qq{ Semantics were specified as "$semantics"\n}
926             );
927             } ## end if ( not $allowed_semantics->{$semantics} )
928              
929             } ## end CHECK_SEMANTICS:
930             CHECK_BLESSING: {
931 41075 50       48308 if ( not $blessing ) {
  41075         62783  
932 0         0 $blessing = '::undef';
933 0         0 last CHECK_BLESSING;
934             }
935 41075 100       69186 last CHECK_BLESSING if $blessing eq '::undef';
936             last CHECK_BLESSING
937 3686 50       12565 if $blessing =~ /\A [[:alpha:]] [:\w]* \z /xms;
938 0         0 Marpa::R2::exception(
939             q{Unknown blessing for lexeme },
940             $grammar->symbol_name($lexeme_id),
941             "\n",
942             qq{ Blessing as specified as "$blessing"\n}
943             );
944             } ## end CHECK_BLESSING:
945 41075         59786 $semantics_by_lexeme_id[$lexeme_id] = $semantics;
946 41075         67315 $blessing_by_lexeme_id[$lexeme_id] = $blessing;
947              
948             } ## end LEXEME: for my $lexeme_id ( 0 .. $#{$symbols} )
949              
950             }
951              
952 1118         2493 my $null_values = $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES];
953              
954 1118         2501 state $op_bless = Marpa::R2::Thin::op('bless');
955 1118         2026 state $op_callback = Marpa::R2::Thin::op('callback');
956 1118         1997 state $op_push_constant = Marpa::R2::Thin::op('push_constant');
957 1118         2001 state $op_push_g1_length = Marpa::R2::Thin::op('push_g1_length');
958 1118         1929 state $op_push_g1_len = Marpa::R2::Thin::op('push_g1_len');
959 1118         1910 state $op_push_length = Marpa::R2::Thin::op('push_length');
960 1118         1975 state $op_push_undef = Marpa::R2::Thin::op('push_undef');
961 1118         1792 state $op_push_one = Marpa::R2::Thin::op('push_one');
962 1118         1863 state $op_push_sequence = Marpa::R2::Thin::op('push_sequence');
963 1118         1800 state $op_push_g1_start = Marpa::R2::Thin::op('push_g1_start');
964 1118         3415 state $op_push_start_location =
965             Marpa::R2::Thin::op('push_start_location');
966 1118         1892 state $op_push_values = Marpa::R2::Thin::op('push_values');
967 1118         1944 state $op_result_is_array = Marpa::R2::Thin::op('result_is_array');
968 1118         1830 state $op_result_is_constant = Marpa::R2::Thin::op('result_is_constant');
969 1118         1857 state $op_result_is_n_of_sequence =
970             Marpa::R2::Thin::op('result_is_n_of_sequence');
971 1118         1809 state $op_result_is_rhs_n = Marpa::R2::Thin::op('result_is_rhs_n');
972 1118         1906 state $op_result_is_token_value =
973             Marpa::R2::Thin::op('result_is_token_value');
974 1118         1799 state $op_result_is_undef = Marpa::R2::Thin::op('result_is_undef');
975              
976 1118         1804 my @nulling_symbol_by_semantic_rule;
977 1118         1749 NULLING_SYMBOL: for my $nulling_symbol ( 0 .. $#{$null_values} ) {
  1118         2776  
978 31648         38656 my $semantic_rule = $null_values->[$nulling_symbol];
979 31648 100       53680 next NULLING_SYMBOL if not defined $semantic_rule;
980 2112         4181 $nulling_symbol_by_semantic_rule[$semantic_rule] = $nulling_symbol;
981             } ## end NULLING_SYMBOL: for my $nulling_symbol ( 0 .. $#{$null_values} )
982              
983 1118         2563 my @work_list = ();
984 1118         3871 RULE: for my $rule_id ( $grammar->rule_ids() ) {
985              
986 30996         41547 my $semantics = $semantics_by_rule_id[$rule_id];
987 30996         39111 my $blessing = $blessing_by_rule_id[$rule_id];
988              
989 30996 100       49753 $semantics = '::undef' if $semantics eq '::!default';
990 30996 100       49496 $semantics = '[values]' if $semantics eq '::array';
991 30996 100       47601 $semantics = '::undef' if $semantics eq '::whatever';
992 30996 100       49349 $semantics = '::rhs0' if $semantics eq '::first';
993              
994 30996         69545 push @work_list, [ $rule_id, undef, $semantics, $blessing ];
995             } ## end RULE: for my $rule_id ( $grammar->rule_ids() )
996              
997 1118         2840 RULE: for my $lexeme_id ( 0 .. $#{$symbols} ) {
  1118         2897  
998              
999 41075         55513 my $semantics = $semantics_by_lexeme_id[$lexeme_id];
1000 41075         50784 my $blessing = $blessing_by_lexeme_id[$lexeme_id];
1001              
1002 41075 100       67842 $semantics = '::value' if $semantics eq '::!default';
1003 41075 50       63639 $semantics = '[value]' if $semantics eq '::array';
1004              
1005 41075         94629 push @work_list, [ undef, $lexeme_id, $semantics, $blessing ];
1006             } ## end RULE: for my $lexeme_id ( 0 .. $#{$symbols} )
1007              
1008             # Registering operations is postponed to this point, because
1009             # the valuator must exist for this to happen. In the future,
1010             # it may be best to have a separate semantics object.
1011 1118         2406 my @nulling_closures = ();
1012 1118         1932 my @registrations = ();
1013 1118         1801 my $top_nulling_ops;
1014              
1015 1118         2354 WORK_ITEM: for my $work_item (@work_list) {
1016 72071         92127 my ( $rule_id, $lexeme_id, $semantics, $blessing ) = @{$work_item};
  72071         135618  
1017              
1018 72071         102199 my ( $closure, $rule, $rule_length, $is_sequence_rule,
1019             $is_discard_sequence_rule, $nulling_symbol_id );
1020 72071 100       118166 if ( defined $rule_id ) {
1021 30996         43199 $nulling_symbol_id = $nulling_symbol_by_semantic_rule[$rule_id];
1022 30996         40332 $closure = $closure_by_rule_id[$rule_id];
1023 30996         43427 $rule = $rules->[$rule_id];
1024 30996         73260 $rule_length = $grammar_c->rule_length($rule_id);
1025 30996         65713 $is_sequence_rule = defined $grammar_c->sequence_min($rule_id);
1026 30996   100     60591 $is_discard_sequence_rule = $is_sequence_rule
1027             && $rule->[Marpa::R2::Internal::Rule::DISCARD_SEPARATION];
1028             } ## end if ( defined $rule_id )
1029              
1030             # Determine the "fate" of the array of child values
1031 72071         87930 my $array_fate;
1032             ARRAY_FATE: {
1033 72071 100 100     88031 if ( defined $closure and ref $closure eq 'CODE' ) {
  72071         133851  
1034 4569         6523 $array_fate = $op_callback;
1035 4569         6760 last ARRAY_FATE;
1036              
1037             }
1038              
1039 67502 100       129336 if ( ( substr $semantics, 0, 1 ) eq '[' ) {
1040 27370         34908 $array_fate = $op_result_is_array;
1041 27370         38582 last ARRAY_FATE;
1042             }
1043             } ## end ARRAY_FATE:
1044              
1045 72071         95938 my @ops = ();
1046              
1047             SET_OPS: {
1048              
1049 72071 100       88642 if ( $semantics eq '::undef' ) {
  72071         120437  
1050 1768         2571 @ops = ($op_result_is_undef);
1051 1768         2358 last SET_OPS;
1052             }
1053              
1054             DO_CONSTANT: {
1055 70303 100       83656 last DO_CONSTANT if not defined $rule_id;
  70303         119041  
1056 29228         40286 my $thingy_ref = $closure_by_rule_id[$rule_id];
1057 29228 100       52979 last DO_CONSTANT if not defined $thingy_ref;
1058 4604         9545 my $ref_type = Scalar::Util::reftype $thingy_ref;
1059 4604 50       8707 if ( $ref_type eq q{} ) {
1060 0         0 my $rule_desc = rule_describe( $grammar, $rule_id );
1061 0         0 Marpa::R2::exception(
1062             qq{An action resolved to a scalar.\n},
1063             qq{ This is not allowed.\n},
1064             qq{ A constant action must be a reference.\n},
1065             qq{ Rule was $rule_desc\n}
1066             );
1067             } ## end if ( $ref_type eq q{} )
1068              
1069 4604 100       8039 if ( $ref_type eq 'CODE' ) {
1070              
1071             # Set the nulling closure if this is the nulling symbol of a rule
1072 4569 100 66     9443 $nulling_closures[$nulling_symbol_id] = $thingy_ref
1073             if defined $nulling_symbol_id
1074             and defined $rule_id;
1075 4569         7158 last DO_CONSTANT;
1076             } ## end if ( $ref_type eq 'CODE' )
1077 35 100       80 if ( $ref_type eq 'SCALAR' ) {
1078 30         40 my $thingy = ${$thingy_ref};
  30         54  
1079 30 50       62 if ( not defined $thingy ) {
1080 0         0 @ops = ($op_result_is_undef);
1081 0         0 last SET_OPS;
1082             }
1083 30         54 @ops = ( $op_result_is_constant, $thingy_ref );
1084 30         48 last SET_OPS;
1085             } ## end if ( $ref_type eq 'SCALAR' )
1086              
1087             # No test for 'ARRAY' or 'HASH' --
1088             # The ref is currenly only to scalar and code slots in the symbol table,
1089             # and therefore cannot be to (among other things) an ARRAY or HASH
1090              
1091 5 50       10 if ( $ref_type eq 'REF' ) {
1092 5         9 @ops = ( $op_result_is_constant, $thingy_ref );
1093 5         8 last SET_OPS;
1094             }
1095              
1096 0         0 my $rule_desc = rule_describe( $grammar, $rule_id );
1097 0         0 Marpa::R2::exception(
1098             qq{Constant action is not of an allowed type.\n},
1099             qq{ It was of type reference to $ref_type.\n},
1100             qq{ Rule was $rule_desc\n}
1101             );
1102             } ## end DO_CONSTANT:
1103              
1104             # After this point, any closure will be a ref to 'CODE'
1105              
1106 70268 100 100     163573 if ( defined $lexeme_id and $semantics eq '::value' ) {
1107 37142         53355 @ops = ($op_result_is_token_value);
1108 37142         47995 last SET_OPS;
1109             }
1110              
1111             PROCESS_SINGLETON_RESULT: {
1112 33126 100       41527 last PROCESS_SINGLETON_RESULT if not defined $rule_id;
  33126         54364  
1113              
1114 29193         36228 my $singleton;
1115 29193 100       59755 if ( $semantics =~ m/\A [:][:] rhs (\d+) \z/xms ) {
1116 1222         4462 $singleton = $1 + 0;
1117             }
1118              
1119 29193 100       51656 last PROCESS_SINGLETON_RESULT if not defined $singleton;
1120              
1121 1222         1945 my $singleton_element = $singleton;
1122 1222 50       2539 if ($is_discard_sequence_rule) {
1123 0         0 @ops =
1124             ( $op_result_is_n_of_sequence, $singleton_element );
1125 0         0 last SET_OPS;
1126             }
1127 1222 50       2480 if ($is_sequence_rule) {
1128 0         0 @ops = ( $op_result_is_rhs_n, $singleton_element );
1129 0         0 last SET_OPS;
1130             }
1131 1222         2196 my $mask = $rule->[Marpa::R2::Internal::Rule::MASK];
1132             my @elements =
1133 1222         2837 grep { $mask->[$_] } 0 .. ( $rule_length - 1 );
  1252         3894  
1134 1222 50       3013 if ( not scalar @elements ) {
1135 0         0 my $original_semantics = $semantics_by_rule_id[$rule_id];
1136 0         0 Marpa::R2::exception(
1137             q{Impossible semantics for empty rule: },
1138             $grammar->brief_rule($rule_id),
1139             "\n",
1140             qq{ Semantics were specified as "$original_semantics"\n}
1141             );
1142             } ## end if ( not scalar @elements )
1143 1222         1996 $singleton_element = $elements[$singleton];
1144              
1145 1222 50       2611 if ( not defined $singleton_element ) {
1146 0         0 my $original_semantics = $semantics_by_rule_id[$rule_id];
1147 0         0 Marpa::R2::exception(
1148             q{Impossible semantics for rule: },
1149             $grammar->brief_rule($rule_id),
1150             "\n",
1151             qq{ Semantics were specified as "$original_semantics"\n}
1152             );
1153             } ## end if ( not defined $singleton_element )
1154 1222         2205 @ops = ( $op_result_is_rhs_n, $singleton_element );
1155 1222         2446 last SET_OPS;
1156             } ## end PROCESS_SINGLETON_RESULT:
1157              
1158 31904 50       51970 if ( not defined $array_fate ) {
1159 0         0 @ops = ($op_result_is_undef);
1160 0         0 last SET_OPS;
1161             }
1162              
1163             # if here, $array_fate is defined
1164              
1165 31904         42077 my @bless_ops = ();
1166 31904 100       56242 if ( $blessing ne '::undef' ) {
1167 26059         42595 push @bless_ops, $op_bless, \$blessing;
1168             }
1169              
1170 31904 50       64121 Marpa::R2::exception(qq{Unknown semantics: "$semantics"})
1171             if ( substr $semantics, 0, 1 ) ne '[';
1172              
1173 31904         42027 my @push_ops = ();
1174 31904         51088 my $array_descriptor = substr $semantics, 1, -1;
1175 31904         220275 $array_descriptor =~ s/^\s*|\s*$//g;
1176             RESULT_DESCRIPTOR:
1177 31904         122804 for my $result_descriptor ( split /[,]\s*/xms, $array_descriptor )
1178             {
1179 85959         343682 $result_descriptor =~ s/^\s*|\s*$//g;
1180 85959 100       166951 if ( $result_descriptor eq 'g1start' ) {
1181 562         944 push @push_ops, $op_push_g1_start;
1182 562         1010 next RESULT_DESCRIPTOR;
1183             }
1184 85397 100       136212 if ( $result_descriptor eq 'g1len' ) {
1185 562         795 push @push_ops, $op_push_g1_len;
1186 562         913 next RESULT_DESCRIPTOR;
1187             }
1188 84835 100       132311 if ( $result_descriptor eq 'g1length' ) {
1189 4         7 push @push_ops, $op_push_g1_length;
1190 4         8 next RESULT_DESCRIPTOR;
1191             }
1192 84831 100       133159 if ( $result_descriptor eq 'start' ) {
1193 26108         37611 push @push_ops, $op_push_start_location;
1194 26108         41681 next RESULT_DESCRIPTOR;
1195             }
1196 58723 100       96141 if ( $result_descriptor eq 'length' ) {
1197 26108         35709 push @push_ops, $op_push_length;
1198 26108         38722 next RESULT_DESCRIPTOR;
1199             }
1200              
1201 32615 100       53672 if ( $result_descriptor eq 'lhs' ) {
1202 9 100       23 if ( defined $rule_id ) {
1203 5         1715 my $lhs_id = $grammar_c->rule_lhs($rule_id);
1204 5         14 push @push_ops, $op_push_constant, \$lhs_id;
1205 5         12 next RESULT_DESCRIPTOR;
1206             }
1207 4 50       16 if ( defined $lexeme_id ) {
1208 4         10 push @push_ops, $op_push_constant, \$lexeme_id;
1209 4         7 next RESULT_DESCRIPTOR;
1210             }
1211 0         0 push @push_ops, $op_push_undef;
1212 0         0 next RESULT_DESCRIPTOR;
1213             } ## end if ( $result_descriptor eq 'lhs' )
1214              
1215 32606 100       53612 if ( $result_descriptor eq 'name' ) {
1216 705 100       1324 if ( defined $rule_id ) {
1217 654         1983 my $name = $grammar->rule_name($rule_id);
1218 654         1310 push @push_ops, $op_push_constant, \$name;
1219 654         1185 next RESULT_DESCRIPTOR;
1220             }
1221 51 50       132 if ( defined $lexeme_id ) {
1222 51         163 my $name = $tracer->symbol_name($lexeme_id);
1223 51         100 push @push_ops, $op_push_constant, \$name;
1224 51         109 next RESULT_DESCRIPTOR;
1225             }
1226 0 0       0 if ( defined $nulling_symbol_id ) {
1227 0         0 my $name = $tracer->symbol_name($nulling_symbol_id);
1228 0         0 push @push_ops, $op_push_constant, \$name;
1229 0         0 next RESULT_DESCRIPTOR;
1230             }
1231 0         0 push @push_ops, $op_push_undef;
1232 0         0 next RESULT_DESCRIPTOR;
1233             } ## end if ( $result_descriptor eq 'name' )
1234              
1235 31901 100       52950 if ( $result_descriptor eq 'symbol' ) {
1236 5 100       12 if ( defined $rule_id ) {
1237 3         10 my $lhs_id = $grammar_c->rule_lhs($rule_id);
1238 3         12 my $name = $tracer->symbol_name($lhs_id);
1239 3         6 push @push_ops, $op_push_constant, \$name;
1240 3         7 next RESULT_DESCRIPTOR;
1241             } ## end if ( defined $rule_id )
1242 2 50       8 if ( defined $lexeme_id ) {
1243 2         6 my $name = $tracer->symbol_name($lexeme_id);
1244 2         5 push @push_ops, $op_push_constant, \$name;
1245 2         5 next RESULT_DESCRIPTOR;
1246             }
1247 0 0       0 if ( defined $nulling_symbol_id ) {
1248 0         0 my $name = $tracer->symbol_name($nulling_symbol_id);
1249 0         0 push @push_ops, $op_push_constant, \$name;
1250 0         0 next RESULT_DESCRIPTOR;
1251             }
1252 0         0 push @push_ops, $op_push_undef;
1253 0         0 next RESULT_DESCRIPTOR;
1254             } ## end if ( $result_descriptor eq 'symbol' )
1255              
1256 31896 100       52227 if ( $result_descriptor eq 'rule' ) {
1257 5 100       14 if ( defined $rule_id ) {
1258 3         5 push @push_ops, $op_push_constant, \$rule_id;
1259 3         7 next RESULT_DESCRIPTOR;
1260             }
1261 2         3 push @push_ops, $op_push_undef;
1262 2         5 next RESULT_DESCRIPTOR;
1263             } ## end if ( $result_descriptor eq 'rule' )
1264 31891 50 66     65923 if ( $result_descriptor eq 'values'
1265             or $result_descriptor eq 'value' )
1266             {
1267 31891 100       52903 if ( defined $lexeme_id ) {
1268 3933         5540 push @push_ops, $op_push_values;
1269 3933         6824 next RESULT_DESCRIPTOR;
1270             }
1271 27958 100       45223 if ($is_sequence_rule) {
1272 1447 100       3283 my $push_op =
1273             $is_discard_sequence_rule
1274             ? $op_push_sequence
1275             : $op_push_values;
1276 1447         2359 push @push_ops, $push_op;
1277 1447         2752 next RESULT_DESCRIPTOR;
1278             } ## end if ($is_sequence_rule)
1279 26511         47980 my $mask = $rule->[Marpa::R2::Internal::Rule::MASK];
1280 26511 100       47684 if ( $rule_length > 0 ) {
1281             push @push_ops,
1282 25700 100       50623 map { $mask->[$_] ? ( $op_push_one, $_ ) : () }
  50038         135234  
1283             0 .. $rule_length - 1;
1284             }
1285 26511         55269 next RESULT_DESCRIPTOR;
1286             } ## end if ( $result_descriptor eq 'values' or ...)
1287             Marpa::R2::exception(
1288 0         0 qq{Unknown result descriptor: "$result_descriptor"\n},
1289             qq{ The full semantics were "$semantics"}
1290             );
1291             } ## end RESULT_DESCRIPTOR: for my $result_descriptor ( split /[,]\s*/xms, ...)
1292 31904         79865 @ops = ( @push_ops, @bless_ops, $array_fate );
1293              
1294             } ## end SET_OPS:
1295              
1296 72071 100       122958 if ( defined $rule_id ) {
1297 30996         85610 push @registrations, [ 'rule', $rule_id, @ops ];
1298             }
1299              
1300 72071 100       119695 if ( defined $nulling_symbol_id ) {
1301              
1302 2112         5083 push @registrations, [ 'nulling', $nulling_symbol_id, @ops ];
1303             } ## end if ( defined $nulling_symbol_id )
1304              
1305 72071 100       135486 if ( defined $lexeme_id ) {
1306 41075         113614 push @registrations, [ 'token', $lexeme_id, @ops ];
1307             }
1308              
1309             } ## end WORK_ITEM: for my $work_item (@work_list)
1310              
1311             SLR_NULLING_GRAMMAR_HACK: {
1312 1118 100       2220 last SLR_NULLING_GRAMMAR_HACK if not $Marpa::R2::Context::slr;
  1118         3134  
1313              
1314             # A hack for nulling SLR grammars --
1315             # the nulling semantics of the start symbol should
1316             # be those of the symbol on the
1317             # RHS of the start rule --
1318             # so copy them.
1319              
1320 881         3878 my $start_symbol_id = $tracer->symbol_by_name('[:start]');
1321             last SLR_NULLING_GRAMMAR_HACK
1322 881 100       4567 if not $grammar_c->symbol_is_nullable($start_symbol_id);
1323              
1324 326         560 my $start_rhs_symbol_id;
1325 326         862 RULE: for my $rule_id ( $grammar->rule_ids() ) {
1326 848         1927 my ( $lhs, $rhs0 ) = $tracer->rule_expand($rule_id);
1327 848 100       2058 if ( $start_symbol_id == $lhs ) {
1328 326         482 $start_rhs_symbol_id = $rhs0;
1329 326         569 last RULE;
1330             }
1331             } ## end RULE: for my $rule_id ( $grammar->rule_ids() )
1332              
1333 326         619 REGISTRATION: for my $registration (@registrations) {
1334 704         946 my ( $type, $nulling_symbol_id ) = @{$registration};
  704         1225  
1335 704 100       1423 if ( $nulling_symbol_id == $start_rhs_symbol_id ) {
1336 326         462 my ( undef, undef, @ops ) = @{$registration};
  326         713  
1337 326         1160 push @registrations, [ 'nulling', $start_symbol_id, @ops ];
1338 326         669 $nulling_closures[$start_symbol_id] =
1339             $nulling_closures[$start_rhs_symbol_id];
1340 326         698 last REGISTRATION;
1341             } ## end if ( $nulling_symbol_id == $start_rhs_symbol_id )
1342             } ## end REGISTRATION: for my $registration (@registrations)
1343             } ## end SLR_NULLING_GRAMMAR_HACK:
1344              
1345 1118         2564 $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] =
1346             \@registrations;
1347 1118         2105 $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_SYMBOL_ID] =
1348             \@nulling_closures;
1349 1118         39030 $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_RULE_ID] =
1350             \@closure_by_rule_id;
1351              
1352             } ## end sub registration_init
1353              
1354             # Returns false if no parse
1355             sub Marpa::R2::Recognizer::value {
1356 8082     8082 0 72903 my ( $recce, $slr, $per_parse_arg ) = @_;
1357 8082         14710 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
1358 8082         11955 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
1359 8082         11871 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1360 8082         12102 my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER];
1361              
1362 8082   50     25522 my $trace_actions =
1363             $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0;
1364 8082   100     21493 my $trace_values =
1365             $recce->[Marpa::R2::Internal::Recognizer::TRACE_VALUES] // 0;
1366 8082         19102 my $trace_file_handle =
1367             $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE];
1368 8082         14444 local $Marpa::R2::Internal::TRACE_FH = $trace_file_handle;
1369              
1370 8082         13199 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
1371 8082         11406 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
1372              
1373 8082 100       17699 if ( scalar @_ != 1 ) {
1374 5732 50       14379 Marpa::R2::exception(
1375             'Too many arguments to Marpa::R2::Recognizer::value')
1376             if ref $slr ne 'Marpa::R2::Scanless::R';
1377             }
1378              
1379 8082   100     18989 $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE] //= 'tree';
1380 8082 50       16100 if ( $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE] ne 'tree' ) {
1381 0         0 Marpa::R2::exception(
1382             "value() called when recognizer is not in tree mode\n",
1383             ' The current mode is "',
1384             $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE],
1385             qq{"\n}
1386             );
1387             } ## end if ( $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE...])
1388              
1389 8082         22497 my $furthest_earleme = $recce_c->furthest_earleme();
1390 8082         18738 my $last_completed_earleme = $recce_c->current_earleme();
1391 8082 50       16591 Marpa::R2::exception(
1392             "Attempt to evaluate incompletely recognized parse:\n",
1393             " Last token ends at location $furthest_earleme\n",
1394             " Recognition done only as far as location $last_completed_earleme\n"
1395             ) if $furthest_earleme > $last_completed_earleme;
1396              
1397 8082         12196 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
1398              
1399 8082 100       16661 if ($tree) {
1400              
1401             # On second and later calls to value() in a parse series, we need
1402             # to check the per-parse arg
1403             CHECK_ARG: {
1404 6944         9784 my $package_source = $recce
  6944         11106  
1405             ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE];
1406             last CHECK_ARG
1407 6944 100       14980 if $package_source eq 'semantics_package'; # Anything is OK
1408 2114 50       3813 if ( $package_source eq 'legacy' ) {
1409 2114 50       3580 if ( defined $per_parse_arg ) {
1410 0         0 Marpa::R2::exception(
1411             "value() called with an argument while incompatible options are in use.\n",
1412             " Often this means that the discouraged 'action_object' named argument was used,\n",
1413             " and that 'semantics_package' should be used instead.\n"
1414             );
1415             } ## end if ( defined $per_parse_arg )
1416 2114         3538 last CHECK_ARG;
1417             } ## end if ( $package_source eq 'legacy' )
1418              
1419             # If here the resolve package source is 'arg'
1420 0 0       0 if ( not defined $per_parse_arg ) {
1421 0         0 Marpa::R2::exception(
1422             "No value() arg, when one is required to resolve semantics.\n",
1423             " Once value() has been called with a argument whose blessing is used to\n",
1424             " find the parse's semantics closures, it must always be called with an arg\n",
1425             " that is blessed in the same package\n",
1426             q{ In this case, the package was "},
1427             $recce
1428             ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE],
1429             qq{"\n"}
1430             );
1431             } ## end if ( not defined $per_parse_arg )
1432              
1433 0         0 my $arg_blessing = Scalar::Util::blessed $per_parse_arg;
1434 0 0       0 if ( not defined $arg_blessing ) {
1435 0         0 Marpa::R2::exception(
1436             "value() arg is not blessed when required for the semantics.\n",
1437             " Once value() has been called with a argument whose blessing is used to\n",
1438             " find the parse's semantics closures, it must always be called with an arg\n",
1439             " that is blessed in the same package\n",
1440             q{ In this case, the original package was "},
1441             $recce
1442             ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE],
1443             qq{"\n"},
1444             qq{ and the blessing in this call was "$arg_blessing"\n}
1445             );
1446             } ## end if ( not defined $arg_blessing )
1447              
1448 0         0 my $required_blessing =
1449             $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE];
1450 0 0       0 if ( $arg_blessing ne $required_blessing ) {
1451 0         0 Marpa::R2::exception(
1452             "value() arg is blessed into the wrong package.\n",
1453             " Once value() has been called with a argument whose blessing is used to\n",
1454             " find the parse's semantics closures, it must always be called with an arg\n",
1455             " that is blessed in the same package\n",
1456             qq{ In this case, the original package was "$required_blessing" and \n},
1457             qq{ and the blessing in this call was "$arg_blessing"\n}
1458             );
1459             } ## end if ( $arg_blessing ne $required_blessing )
1460              
1461             } ## end CHECK_ARG:
1462              
1463             # If we have a bocage, we are initialized
1464 6944 50       13564 if ( not $tree ) {
1465              
1466             # No tree means we are in ASF mode
1467 0         0 Marpa::R2::exception('value() called for recognizer in ASF mode');
1468             }
1469 6944         10086 my $max_parses =
1470             $recce->[Marpa::R2::Internal::Recognizer::MAX_PARSES];
1471 6944         14835 my $parse_count = $tree->parse_count();
1472 6944 50 66     18447 if ( $max_parses and $parse_count > $max_parses ) {
1473 0         0 Marpa::R2::exception(
1474             "Maximum parse count ($max_parses) exceeded");
1475             }
1476              
1477             } ## end if ($tree)
1478             else {
1479             # No tree, therefore not initialized
1480              
1481 1138         3073 my $order = $recce->ordering_get();
1482 1138 100       2991 return if not $order;
1483 1118         6366 $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C] =
1484             Marpa::R2::Thin::T->new($order);
1485              
1486             } ## end else [ if ($tree) ]
1487              
1488 8062 50       17716 if ( $recce->[Marpa::R2::Internal::Recognizer::TRACE_AND_NODES] ) {
1489 0 0       0 print {$trace_file_handle} 'AND_NODES: ', $recce->show_and_nodes()
  0         0  
1490             or Marpa::R2::exception('print to trace handle failed');
1491             }
1492              
1493 8062 50       16028 if ( $recce->[Marpa::R2::Internal::Recognizer::TRACE_OR_NODES] ) {
1494 0 0       0 print {$trace_file_handle} 'OR_NODES: ', $recce->show_or_nodes()
  0         0  
1495             or Marpa::R2::exception('print to trace handle failed');
1496             }
1497              
1498 8062 50       14702 if ( $recce->[Marpa::R2::Internal::Recognizer::TRACE_BOCAGE] ) {
1499 0 0       0 print {$trace_file_handle} 'BOCAGE: ', $recce->show_bocage()
  0         0  
1500             or Marpa::R2::exception('print to trace handle failed');
1501             }
1502              
1503 8062 100       35023 return if not defined $tree->next();
1504              
1505 7953         13230 local $Marpa::R2::Context::grammar = $grammar;
1506 7953         11534 local $Marpa::R2::Context::rule = undef;
1507 7953         11249 local $Marpa::R2::Context::slr = $slr;
1508 7953 100       15846 local $Marpa::R2::Context::slg =
1509             $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]
1510             if defined $slr;
1511              
1512 7953 100       17021 if ( not $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] ) {
1513 1118         3117 registration_init( $recce, $per_parse_arg );
1514             }
1515              
1516 7952         11966 my $semantics_arg0;
1517             RUN_CONSTRUCTOR: {
1518             # Do not run the constructor if there is a per-parse arg
1519 7952 100       10064 last RUN_CONSTRUCTOR if defined $per_parse_arg;
  7952         14731  
1520              
1521 7904         11609 my $per_parse_constructor =
1522             $recce->[Marpa::R2::Internal::Recognizer::PER_PARSE_CONSTRUCTOR];
1523              
1524             # Do not run the constructor if there isn't one
1525 7904 100       16449 last RUN_CONSTRUCTOR if not defined $per_parse_constructor;
1526              
1527 7         25 my $constructor_arg0;
1528 7 100       33 if ( $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE]
1529             eq 'legacy' )
1530             {
1531 4         13 $constructor_arg0 =
1532             $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT];
1533             } ## end if ( $recce->[...])
1534             else {
1535 3         9 $constructor_arg0 =
1536             $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE];
1537             }
1538 7         29 my @warnings;
1539             my $eval_ok;
1540 7         0 my $fatal_error;
1541             DO_EVAL: {
1542 7         14 local $EVAL_ERROR = undef;
  7         21  
1543             local $SIG{__WARN__} = sub {
1544 0     0   0 push @warnings, [ $_[0], ( caller 0 ) ];
1545 7         100 };
1546              
1547 7         28 $eval_ok = eval {
1548 7         45 $semantics_arg0 = $per_parse_constructor->($constructor_arg0);
1549 7         47 1;
1550             };
1551 7         71 $fatal_error = $EVAL_ERROR;
1552             } ## end DO_EVAL:
1553              
1554 7 50 33     60 if ( not $eval_ok or @warnings ) {
1555 0         0 code_problems(
1556             { fatal_error => $fatal_error,
1557             grammar => $grammar,
1558             eval_ok => $eval_ok,
1559             warnings => \@warnings,
1560             where => 'constructing action object',
1561             }
1562             );
1563             } ## end if ( not $eval_ok or @warnings )
1564             } ## end RUN_CONSTRUCTOR:
1565              
1566 7952   100     41187 $semantics_arg0 //= $per_parse_arg // {};
      66        
1567              
1568 7952         69792 my $value = Marpa::R2::Thin::V->new($tree);
1569 7952 100       17517 if ($slr) {
1570 5681         17654 $value->slr_set( $slr->thin() );
1571             }
1572             else {
1573 2271         3426 my $token_values =
1574             $recce->[Marpa::R2::Internal::Recognizer::TOKEN_VALUES];
1575 2271         6386 $value->valued_force();
1576             TOKEN_IX:
1577 2271         3545 for ( my $token_ix = 2; $token_ix <= $#{$token_values}; $token_ix++ )
  9196         17716  
1578             {
1579 6925         10109 my $token_value = $token_values->[$token_ix];
1580 6925 100       15253 $value->token_value_set( $token_ix, $token_value )
1581             if defined $token_value;
1582             } ## end TOKEN_IX: for ( my $token_ix = 2; $token_ix <= $#{...})
1583             } ## end else [ if ($slr) ]
1584 7952         15032 local $Marpa::R2::Internal::Context::VALUATOR = $value;
1585 7952 100       24770 value_trace( $value, $trace_values ? 1 : 0 );
1586 7952         30995 $value->trace_values($trace_values);
1587 7952         79413 $value->stack_mode_set();
1588              
1589 7952         14528 my $null_values = $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES];
1590 7952         11644 my $nulling_closures =
1591             $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_SYMBOL_ID];
1592 7952         11735 my $rule_closures =
1593             $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_RULE_ID];
1594             REGISTRATION:
1595 7952         11271 for my $registration (
1596 7952         18593 @{ $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] } )
1597             {
1598 189766         231231 my ( $type, $id, @raw_ops ) = @{$registration};
  189766         346765  
1599 189766         253535 my @ops = ();
1600             PRINT_TRACES: {
1601 189766 50       225961 last PRINT_TRACES if $trace_values <= 2;
  189766         327369  
1602 0 0       0 if ( $type eq 'nulling' ) {
1603 0 0       0 say {$trace_file_handle}
  0         0  
1604             "Registering semantics for nulling symbol: ",
1605             $grammar->symbol_name($id),
1606             "\n", ' Semantics are ', show_semantics(@raw_ops)
1607             or
1608             Marpa::R2::exception('Cannot say to trace file handle');
1609 0         0 last PRINT_TRACES;
1610             } ## end if ( $type eq 'nulling' )
1611 0 0       0 say {$trace_file_handle}
  0         0  
1612             "Registering semantics for $type: ",
1613             $grammar->symbol_name($id),
1614             "\n", ' Semantics are ', show_semantics(@raw_ops)
1615             or Marpa::R2::exception('Cannot say to trace file handle');
1616             } ## end PRINT_TRACES:
1617              
1618 189766         266228 OP: for my $raw_op (@raw_ops) {
1619 519496 100       801575 if ( ref $raw_op ) {
1620 28116         35366 push @ops, $value->constant_register( ${$raw_op} );
  28116         58733  
1621 28116         44676 next OP;
1622             }
1623 491380         670997 push @ops, $raw_op;
1624             } ## end OP: for my $raw_op (@raw_ops)
1625 189766 100       314997 if ( $type eq 'token' ) {
1626 94226         224088 $value->token_register( $id, @ops );
1627 94226         156399 next REGISTRATION;
1628             }
1629 95540 100       149532 if ( $type eq 'nulling' ) {
1630 7291         20033 $value->nulling_symbol_register( $id, @ops );
1631 7291         12606 next REGISTRATION;
1632             }
1633 88249 50       140692 if ( $type eq 'rule' ) {
1634 88249         233130 $value->rule_register( $id, @ops );
1635 88249         163772 next REGISTRATION;
1636             }
1637             Marpa::R2::exception(
1638 0         0 'Registration: with unknown type: ',
1639             Data::Dumper::Dumper($registration)
1640             );
1641             } ## end REGISTRATION: for my $registration ( @{ $recce->[...]})
1642              
1643 7952         11479 STEP: while (1) {
1644 130274         594022 my ( $value_type, @value_data ) = $value->stack_step();
1645              
1646 130274 100       272659 if ($trace_values) {
1647 100         141 EVENT: while (1) {
1648 114         224 my $event = $value->event();
1649 114 100       222 last EVENT if not defined $event;
1650 14         20 my ( $event_type, @event_data ) = @{$event};
  14         35  
1651 14 50       31 if ( $event_type eq 'MARPA_STEP_TOKEN' ) {
1652 14         30 my ( $token_id, $token_value_ix, $token_value ) = @event_data;
1653 14         35 trace_token_evaluation( $recce, $value, $token_id,
1654             $token_value );
1655 14         38 next EVENT;
1656             } ## end if ( $event_type eq 'MARPA_STEP_TOKEN' )
1657 0         0 say {$trace_file_handle} join q{ },
1658             'value event:',
1659 0 0 0     0 map { $_ // 'undef' } $event_type, @event_data
  0         0  
1660             or Marpa::R2::exception('say to trace handle failed');
1661             } ## end EVENT: while (1)
1662              
1663 100 50       190 if ( $trace_values >= 9 ) {
1664 0         0 for my $i ( reverse 0 .. $value->highest_index ) {
1665 0 0       0 printf {$trace_file_handle} "Stack position %3d:\n", $i,
  0         0  
1666             or
1667             Marpa::R2::exception('print to trace handle failed');
1668 0 0       0 print {$trace_file_handle} q{ },
  0         0  
1669             Data::Dumper->new( [ \$value->absolute($i) ] )
1670             ->Terse(1)->Dump
1671             or
1672             Marpa::R2::exception('print to trace handle failed');
1673             } ## end for my $i ( reverse 0 .. $value->highest_index )
1674             } ## end if ( $trace_values >= 9 )
1675              
1676             } ## end if ($trace_values)
1677              
1678 130274 100       230198 last STEP if not defined $value_type;
1679 122332 100       220228 next STEP if $value_type eq 'trace';
1680              
1681 122302 100       195777 if ( $value_type eq 'MARPA_STEP_NULLING_SYMBOL' ) {
1682 1324         1929 my ($token_id) = @value_data;
1683 1324         2116 my $value_ref = $nulling_closures->[$token_id];
1684 1324         2700 my $result;
1685              
1686             my @warnings;
1687 1324         0 my $eval_ok;
1688              
1689             DO_EVAL: {
1690 1324         1684 local $SIG{__WARN__} = sub {
1691 0     0   0 push @warnings, [ $_[0], ( caller 0 ) ];
1692 1324         6035 };
1693              
1694 1324         2490 $eval_ok = eval {
1695 1324         2028 local $Marpa::R2::Context::rule =
1696             $null_values->[$token_id];
1697 1324         2858 $result = $value_ref->($semantics_arg0);
1698 1324         14325 1;
1699             };
1700              
1701             } ## end DO_EVAL:
1702              
1703 1324 50 33     4794 if ( not $eval_ok or @warnings ) {
1704 0         0 my $fatal_error = $EVAL_ERROR;
1705 0         0 code_problems(
1706             { fatal_error => $fatal_error,
1707             grammar => $grammar,
1708             eval_ok => $eval_ok,
1709             warnings => \@warnings,
1710             where => 'computing value',
1711             long_where => 'Computing value for null symbol: '
1712             . $grammar->symbol_name($token_id),
1713             }
1714             );
1715             } ## end if ( not $eval_ok or @warnings )
1716              
1717 1324         3442 $value->result_set($result);
1718 1324 50       2351 trace_token_evaluation( $recce, $value, $token_id, \$result )
1719             if $trace_values;
1720 1324         2372 next STEP;
1721             } ## end if ( $value_type eq 'MARPA_STEP_NULLING_SYMBOL' )
1722              
1723 120978 100       212919 if ( $value_type eq 'MARPA_STEP_RULE' ) {
1724 120929         183838 my ( $rule_id, $values ) = @value_data;
1725 120929         184179 my $closure = $rule_closures->[$rule_id];
1726              
1727 120929 50       195165 next STEP if not defined $closure;
1728 120929         150986 my $result;
1729              
1730 120929 50       227044 if ( ref $closure eq 'CODE' ) {
1731 120929         163635 my @warnings;
1732             my $eval_ok;
1733             DO_EVAL: {
1734 120929         153022 local $SIG{__WARN__} = sub {
1735 4     4   80 push @warnings, [ $_[0], ( caller 0 ) ];
1736 120929         492431 };
1737 120929         213893 local $Marpa::R2::Context::rule = $rule_id;
1738              
1739 120929 50       265438 if ( Scalar::Util::blessed($values) ) {
1740 0         0 $eval_ok = eval {
1741 0         0 $result = $closure->( $semantics_arg0, $values );
1742 0         0 1;
1743             };
1744 0         0 last DO_EVAL;
1745             } ## end if ( Scalar::Util::blessed($values) )
1746 120929         169129 $eval_ok = eval {
1747 120929         147606 $result = $closure->( $semantics_arg0, @{$values} );
  120929         271511  
1748 120921         2293937 1;
1749             };
1750              
1751             } ## end DO_EVAL:
1752              
1753 120929 100 100     425567 if ( not $eval_ok or @warnings ) {
1754 10         24 my $fatal_error = $EVAL_ERROR;
1755 10         51 code_problems(
1756             { fatal_error => $fatal_error,
1757             grammar => $grammar,
1758             eval_ok => $eval_ok,
1759             warnings => \@warnings,
1760             where => 'computing value',
1761             long_where => 'Computing value for rule: '
1762             . $grammar->brief_rule($rule_id),
1763             }
1764             );
1765             } ## end if ( not $eval_ok or @warnings )
1766             } ## end if ( ref $closure eq 'CODE' )
1767             else {
1768 0         0 $result = ${$closure};
  0         0  
1769             }
1770 120919         314675 $value->result_set($result);
1771              
1772 120919 100       201581 if ($trace_values) {
1773 18 50       38 say {$trace_file_handle}
  18         54  
1774             trace_stack_1( $grammar, $recce, $value, $values,
1775             $rule_id )
1776             or Marpa::R2::exception('Could not print to trace file');
1777 18 50       38 print {$trace_file_handle}
  18         78  
1778             'Calculated and pushed value: ',
1779             Data::Dumper->new( [$result] )->Terse(1)->Dump
1780             or Marpa::R2::exception('print to trace handle failed');
1781             } ## end if ($trace_values)
1782              
1783 120919         243559 next STEP;
1784              
1785             } ## end if ( $value_type eq 'MARPA_STEP_RULE' )
1786              
1787 49 50       106 if ( $value_type eq 'MARPA_STEP_TRACE' ) {
1788              
1789 49 100       98 if ( my $trace_output = trace_op( $grammar, $recce, $value ) ) {
1790 2 50       4 print {$trace_file_handle} $trace_output
  2         10  
1791             or Marpa::R2::exception('Could not print to trace file');
1792             }
1793              
1794 49         88 next STEP;
1795              
1796             } ## end if ( $value_type eq 'MARPA_STEP_TRACE' )
1797              
1798 0         0 die "Internal error: Unknown value type $value_type";
1799              
1800             } ## end STEP: while (1)
1801              
1802 7942         91317 return \( $value->absolute(0) );
1803              
1804             } ## end sub Marpa::R2::Recognizer::value
1805              
1806             sub do_high_rule_only {
1807 95     95   221 my ($recce) = @_;
1808 95         168 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
1809 95         370 $order->high_rank_only_set(1);
1810 95         408 $order->rank();
1811 95         175 return 1;
1812             } ## end sub do_high_rule_only
1813              
1814             sub do_rank_by_rule {
1815 8     8   22 my ($recce) = @_;
1816 8         22 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
1817              
1818             # Rank by rule is the default, but just in case
1819 8         52 $order->high_rank_only_set(0);
1820 8         65 $order->rank();
1821 8         18 return 1;
1822             } ## end sub do_rank_by_rule
1823              
1824             # INTERNAL OK AFTER HERE _marpa_
1825              
1826             sub Marpa::R2::Recognizer::show_bocage {
1827 1     1 0 5 my ($recce, $verbose) = @_;
1828 1   50     7 $verbose //= 0;
1829 1         2 my @data = ();
1830 1         3 my $id = 0;
1831 1         2 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1832 1         3 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1833 1         3 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
1834 1         2 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
1835 1         3 OR_NODE: for ( my $or_node_id = 0;; $or_node_id++ ) {
1836 21         50 my $irl_id = $bocage->_marpa_b_or_node_irl($or_node_id);
1837 21 100       47 last OR_NODE if not defined $irl_id;
1838 20         36 my $position = $bocage->_marpa_b_or_node_position($or_node_id);
1839 20         38 my $or_origin = $bocage->_marpa_b_or_node_origin($or_node_id);
1840 20         37 my $origin_earleme = $recce_c->earleme($or_origin);
1841 20         34 my $or_set = $bocage->_marpa_b_or_node_set($or_node_id);
1842 20         35 my $current_earleme = $recce_c->earleme($or_set);
1843 20         54 my @and_node_ids =
1844             ( $bocage->_marpa_b_or_node_first_and($or_node_id)
1845             .. $bocage->_marpa_b_or_node_last_and($or_node_id) );
1846             AND_NODE:
1847              
1848 20         36 for my $and_node_id (@and_node_ids) {
1849 23         43 my $symbol = $bocage->_marpa_b_and_node_symbol($and_node_id);
1850 23         28 my $cause_tag;
1851              
1852 23 100       40 if ( defined $symbol ) {
1853 7         13 $cause_tag = "S$symbol";
1854             }
1855 23         41 my $cause_id = $bocage->_marpa_b_and_node_cause($and_node_id);
1856 23 100       46 if ( defined $cause_id ) {
1857 16         33 $cause_tag = "OR#$cause_id=" .
1858             Marpa::R2::Recognizer::or_node_tag( $recce, $cause_id );
1859             }
1860 23         39 my $parent_tag =
1861             Marpa::R2::Recognizer::or_node_tag( $recce, $or_node_id );
1862 23         51 my $predecessor_id =
1863             $bocage->_marpa_b_and_node_predecessor($and_node_id);
1864 23         41 my $predecessor_tag = q{-};
1865 23 100       46 if ( defined $predecessor_id ) {
1866 10         37 $predecessor_tag =
1867             $predecessor_tag = "OR#$predecessor_id=" .
1868             Marpa::R2::Recognizer::or_node_tag( $recce, $predecessor_id );
1869             }
1870            
1871 23         83 my $tag = join q{ }, "AND#$and_node_id:", "parent=OR#$or_node_id=$parent_tag",
1872             "pred=$predecessor_tag", "cause=$cause_tag";
1873              
1874 23         94 push @data, [ $and_node_id, $tag ];
1875             } ## end AND_NODE: for my $and_node_id (@and_node_ids)
1876             } ## end OR_NODE: for ( my $or_node_id = 0;; $or_node_id++ )
1877 1         10 my @sorted_data = map { $_->[-1] } sort { $a->[0] <=> $b->[0] } @data;
  23         39  
  22         32  
1878 1         53 return ( join "\n", @sorted_data ) . "\n";
1879             } ## end sub Marpa::R2::Recognizer::show_bocage
1880              
1881             sub Marpa::R2::Recognizer::and_node_tag {
1882 83     83 0 157 my ( $recce, $and_node_id ) = @_;
1883 83         127 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1884 83         121 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1885 83         182 my $parent_or_node_id = $bocage->_marpa_b_and_node_parent($and_node_id);
1886 83         163 my $origin = $bocage->_marpa_b_or_node_origin($parent_or_node_id);
1887 83         178 my $origin_earleme = $recce_c->earleme($origin);
1888 83         156 my $current_earley_set =
1889             $bocage->_marpa_b_or_node_set($parent_or_node_id);
1890 83         141 my $current_earleme = $recce_c->earleme($current_earley_set);
1891 83         184 my $cause_id = $bocage->_marpa_b_and_node_cause($and_node_id);
1892 83         153 my $predecessor_id = $bocage->_marpa_b_and_node_predecessor($and_node_id);
1893              
1894 83         141 my $middle_earley_set = $bocage->_marpa_b_and_node_middle($and_node_id);
1895 83         139 my $middle_earleme = $recce_c->earleme($middle_earley_set);
1896              
1897 83         157 my $position = $bocage->_marpa_b_or_node_position($parent_or_node_id);
1898 83         255 my $irl_id = $bocage->_marpa_b_or_node_irl($parent_or_node_id);
1899              
1900             #<<< perltidy introduces trailing space on this
1901 83         204 my $tag =
1902             'R'
1903             . $irl_id . q{:}
1904             . $position . q{@}
1905             . $origin_earleme . q{-}
1906             . $current_earleme;
1907             #>>>
1908 83 100       151 if ( defined $cause_id ) {
1909 45         144 my $cause_irl_id = $bocage->_marpa_b_or_node_irl($cause_id);
1910 45         94 $tag .= 'C' . $cause_irl_id;
1911             }
1912             else {
1913 38         82 my $symbol = $bocage->_marpa_b_and_node_symbol($and_node_id);
1914 38         62 $tag .= 'S' . $symbol;
1915             }
1916 83         132 $tag .= q{@} . $middle_earleme;
1917 83         294 return $tag;
1918             } ## end sub Marpa::R2::Recognizer::and_node_tag
1919              
1920             sub Marpa::R2::Recognizer::show_and_nodes {
1921 2     2 0 7 my ($recce, $verbose) = @_;
1922 2   50     15 $verbose //= 0;
1923 2         6 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1924 2         8 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1925 2         3 my $text;
1926 2         8 my @data = ();
1927 2         6 AND_NODE: for ( my $id = 0;; $id++ ) {
1928 46         93 my $parent = $bocage->_marpa_b_and_node_parent($id);
1929 46         79 my $predecessor = $bocage->_marpa_b_and_node_predecessor($id);
1930 46         82 my $cause = $bocage->_marpa_b_and_node_cause($id);
1931 46         77 my $symbol = $bocage->_marpa_b_and_node_symbol($id);
1932 46 100       89 last AND_NODE if not defined $parent;
1933 44         76 my $origin = $bocage->_marpa_b_or_node_origin($parent);
1934 44         70 my $set = $bocage->_marpa_b_or_node_set($parent);
1935 44         84 my $irl_id = $bocage->_marpa_b_or_node_irl($parent);
1936 44         77 my $position = $bocage->_marpa_b_or_node_position($parent);
1937 44         81 my $origin_earleme = $recce_c->earleme($origin);
1938 44         78 my $current_earleme = $recce_c->earleme($set);
1939 44         68 my $middle_earley_set = $bocage->_marpa_b_and_node_middle($id);
1940 44         77 my $middle_earleme = $recce_c->earleme($middle_earley_set);
1941              
1942             #<<< perltidy introduces trailing space on this
1943 44         98 my $desc =
1944             "And-node #$id: R"
1945             . $irl_id . q{:}
1946             . $position . q{@}
1947             . $origin_earleme . q{-}
1948             . $current_earleme;
1949             #>>>
1950 44         52 my $cause_rule = -1;
1951 44 100       80 if ( defined $cause ) {
1952 26         49 my $cause_irl_id = $bocage->_marpa_b_or_node_irl($cause);
1953 26         59 $desc .= 'C' . $cause_irl_id;
1954             }
1955             else {
1956 18         40 $desc .= 'S' . $symbol;
1957             }
1958 44         65 $desc .= q{@} . $middle_earleme;
1959 44 50       75 if ($verbose) {
1960 0 0       0 $desc .= " parent=" . (defined $parent ? "OR#$parent" : '-');
1961 0 0       0 $desc .= " pred=" . (defined $predecessor ? "OR#$predecessor" : '-');
1962 0 0       0 $desc .= " cause=" . (defined $cause ? "OR#$cause" : '-');
1963             }
1964 44         93 push @data, $desc;
1965             } ## end AND_NODE: for ( my $id = 0;; $id++ )
1966 2         29 return ( join "\n", @data ) . "\n";
1967             } ## end sub Marpa::R2::Recognizer::show_and_nodes
1968              
1969             sub Marpa::R2::Recognizer::or_node_tag {
1970 89     89 0 137 my ( $recce, $or_node_id ) = @_;
1971 89         129 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1972 89         155 my $set = $bocage->_marpa_b_or_node_set($or_node_id);
1973 89         162 my $irl_id = $bocage->_marpa_b_or_node_irl($or_node_id);
1974 89         149 my $origin = $bocage->_marpa_b_or_node_origin($or_node_id);
1975 89         142 my $position = $bocage->_marpa_b_or_node_position($or_node_id);
1976 89         259 return 'R' . $irl_id . q{:} . $position . q{@} . $origin . q{-} . $set;
1977             } ## end sub Marpa::R2::Recognizer::or_node_tag
1978              
1979             sub Marpa::R2::Recognizer::show_or_nodes {
1980 2     2 0 29 my ( $recce, $verbose ) = @_;
1981 2         5 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1982 2         5 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1983 2         4 my $text;
1984 2         5 my @data = ();
1985 2         4 my $id = 0;
1986 2         5 OR_NODE: for ( ;; ) {
1987 43         90 my $origin = $bocage->_marpa_b_or_node_origin($id);
1988 43         72 my $set = $bocage->_marpa_b_or_node_set($id);
1989 43         77 my $irl_id = $bocage->_marpa_b_or_node_irl($id);
1990 43         73 my $position = $bocage->_marpa_b_or_node_position($id);
1991 43         58 $id++;
1992 43 100       84 last OR_NODE if not defined $origin;
1993 41         70 my $origin_earleme = $recce_c->earleme($origin);
1994 41         67 my $current_earleme = $recce_c->earleme($set);
1995              
1996             #<<< perltidy introduces trailing space on this
1997 41         101 my $desc =
1998             'R'
1999             . $irl_id . q{:}
2000             . $position . q{@}
2001             . $origin_earleme . q{-}
2002             . $current_earleme;
2003             #>>>
2004 41         136 push @data,
2005             [ $origin_earleme, $current_earleme, $irl_id, $position, $desc ];
2006             } ## end OR_NODE: for ( ;; )
2007 41         68 my @sorted_data = map { $_->[-1] } sort {
2008 2 50 100     27 $a->[0] <=> $b->[0]
  118   100     361  
2009             or $a->[1] <=> $b->[1]
2010             or $a->[2] <=> $b->[2]
2011             or $a->[3] <=> $b->[3]
2012             } @data;
2013 2         36 return ( join "\n", @sorted_data ) . "\n";
2014             } ## end sub Marpa::R2::Recognizer::show_or_nodes
2015              
2016             # Not sorted and therefore not suitable for test suite
2017             sub Marpa::R2::Recognizer::verbose_or_nodes {
2018 0     0 0 0 my ($recce) = @_;
2019 0         0 my $text = q{};
2020             OR_NODE:
2021 0         0 for (
2022             my $or_node_id = 0;
2023             defined( my $or_node_desc = $recce->verbose_or_node($or_node_id) );
2024             $or_node_id++
2025             )
2026             {
2027 0         0 $text .= $or_node_desc;
2028             } ## end OR_NODE: for ( my $or_node_id = 0; defined( my $or_node_desc =...))
2029 0         0 return $text;
2030             } ## end sub Marpa::R2::Recognizer::verbose_or_nodes
2031              
2032             sub Marpa::R2::Recognizer::verbose_or_node {
2033 0     0 0 0 my ( $recce, $or_node_id ) = @_;
2034 0         0 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
2035 0         0 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
2036 0         0 my $origin = $bocage->_marpa_b_or_node_origin($or_node_id);
2037 0 0       0 return if not defined $origin;
2038 0         0 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
2039 0         0 my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER];
2040 0         0 my $set = $bocage->_marpa_b_or_node_set($or_node_id);
2041 0         0 my $irl_id = $bocage->_marpa_b_or_node_irl($or_node_id);
2042 0         0 my $position = $bocage->_marpa_b_or_node_position($or_node_id);
2043 0         0 my $origin_earleme = $recce_c->earleme($origin);
2044 0         0 my $current_earleme = $recce_c->earleme($set);
2045 0         0 my $text =
2046             "OR-node #$or_node_id: R$irl_id" . q{:}
2047             . $position . q{@}
2048             . $origin_earleme . q{-}
2049             . $current_earleme . "\n";
2050 0         0 $text .=
2051             ( q{ } x 4 ) . $tracer->show_dotted_irl( $irl_id, $position ) . "\n";
2052              
2053 0         0 for my $and_node_id ( $bocage->_marpa_b_or_node_first_and($or_node_id)
2054             .. $bocage->_marpa_b_or_node_last_and($or_node_id) )
2055             {
2056 0         0 my $parent = $bocage->_marpa_b_and_node_parent($and_node_id);
2057 0         0 my $predecessor = $bocage->_marpa_b_and_node_predecessor($and_node_id);
2058 0         0 my $cause = $bocage->_marpa_b_and_node_cause($and_node_id);
2059 0         0 my $symbol = $bocage->_marpa_b_and_node_symbol($and_node_id);
2060 0 0       0 last AND_NODE if not defined $parent;
2061 0         0 my $origin = $bocage->_marpa_b_or_node_origin($parent);
2062 0         0 my $set = $bocage->_marpa_b_or_node_set($parent);
2063 0         0 my $irl_id = $bocage->_marpa_b_or_node_irl($parent);
2064 0         0 my $position = $bocage->_marpa_b_or_node_position($parent);
2065 0         0 my $origin_earleme = $recce_c->earleme($origin);
2066 0         0 my $current_earleme = $recce_c->earleme($set);
2067 0         0 my $middle_earley_set = $bocage->_marpa_b_and_node_middle($and_node_id);
2068 0         0 my $middle_earleme = $recce_c->earleme($middle_earley_set);
2069              
2070             #<<< perltidy introduces trailing space on this
2071 0         0 my $desc =
2072             "And-node #$and_node_id: R"
2073             . $irl_id . q{:}
2074             . $position . q{@}
2075             . $origin_earleme . q{-}
2076             . $current_earleme;
2077             #>>>
2078 0         0 my $cause_rule = -1;
2079 0 0       0 if ( defined $cause ) {
2080 0         0 my $cause_irl_id = $bocage->_marpa_b_or_node_irl($cause);
2081 0         0 $desc .= 'C' . $cause_irl_id;
2082             }
2083             else {
2084 0         0 $desc .= 'S' . $symbol;
2085             }
2086 0         0 $desc .= q{@} . $middle_earleme;
2087 0         0 $text .= " $desc\n";
2088             }
2089 0         0 return $text;
2090             } ## end sub Marpa::R2::Recognizer::verbose_or_node
2091              
2092             sub Marpa::R2::Recognizer::show_nook {
2093 44     44 0 77 my ( $recce, $nook_id, $verbose ) = @_;
2094 44         60 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
2095 44         58 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
2096 44         60 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
2097              
2098 44         91 my $or_node_id = $tree->_marpa_t_nook_or_node($nook_id);
2099 44 100       80 return if not defined $or_node_id;
2100              
2101 40         73 my $text = "o$or_node_id";
2102 40   100     101 my $parent = $tree->_marpa_t_nook_parent($nook_id) // q{-};
2103             CHILD_TYPE: {
2104 40 100       53 if ( $tree->_marpa_t_nook_is_cause($nook_id) ) {
  40         93  
2105 24         43 $text .= "[c$parent]";
2106 24         32 last CHILD_TYPE;
2107             }
2108 16 100       64 if ( $tree->_marpa_t_nook_is_predecessor($nook_id) ) {
2109 12         20 $text .= "[p$parent]";
2110 12         18 last CHILD_TYPE;
2111             }
2112 4         7 $text .= '[-]';
2113             } ## end CHILD_TYPE:
2114 40         71 my $or_node_tag =
2115             Marpa::R2::Recognizer::or_node_tag( $recce, $or_node_id );
2116 40         66 $text .= " $or_node_tag";
2117              
2118 40         56 $text .= ' p';
2119 40 50       92 $text .=
2120             $tree->_marpa_t_nook_predecessor_is_ready($nook_id)
2121             ? q{=ok}
2122             : q{-};
2123 40         59 $text .= ' c';
2124 40 50       83 $text .= $tree->_marpa_t_nook_cause_is_ready($nook_id) ? q{=ok} : q{-};
2125 40         53 $text .= "\n";
2126              
2127             DESCRIBE_CHOICES: {
2128 40         53 my $this_choice = $tree->_marpa_t_nook_choice($nook_id);
  40         69  
2129 40         58 CHOICE: for ( my $choice_ix = 0;; $choice_ix++ ) {
2130 89         167 my $and_node_id =
2131             $order->_marpa_o_and_node_order_get( $or_node_id,
2132             $choice_ix );
2133 89 100       187 last CHOICE if not defined $and_node_id;
2134 49         99 $text .= " o$or_node_id" . '[' . $choice_ix . ']';
2135 49 100 66     157 if ( defined $this_choice and $this_choice == $choice_ix ) {
2136 40         55 $text .= q{*};
2137             }
2138 49         67 my $and_node_tag =
2139             Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id );
2140 49         103 $text .= " ::= a$and_node_id $and_node_tag";
2141 49         91 $text .= "\n";
2142             } ## end CHOICE: for ( my $choice_ix = 0;; $choice_ix++ )
2143             } ## end DESCRIBE_CHOICES:
2144 40         83 return $text;
2145             } ## end sub Marpa::R2::Recognizer::show_nook
2146              
2147             sub Marpa::R2::Recognizer::show_tree {
2148 4     4 0 43 my ( $recce, $verbose ) = @_;
2149 4         9 my $text = q{};
2150 4         8 NOOK: for ( my $nook_id = 0; 1; $nook_id++ ) {
2151 44         79 my $nook_text = $recce->show_nook( $nook_id, $verbose );
2152 44 100       87 last NOOK if not defined $nook_text;
2153 40         87 $text .= "$nook_id: $nook_text";
2154             }
2155 4         25 return $text;
2156             } ## end sub Marpa::R2::Recognizer::show_tree
2157              
2158             sub trace_token_evaluation {
2159 14     14   29 my ( $recce, $value, $token_id, $token_value ) = @_;
2160 14         23 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
2161 14         19 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
2162 14         20 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
2163              
2164 14         46 my $nook_ix = $value->_marpa_v_nook();
2165 14 50       28 if ( not defined $nook_ix ) {
2166 0 0       0 print {$Marpa::R2::Internal::TRACE_FH} "Nulling valuator\n"
  0         0  
2167             or Marpa::R2::exception('Could not print to trace file');
2168 0         0 return;
2169             }
2170 14         39 my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix);
2171 14         33 my $choice = $tree->_marpa_t_nook_choice($nook_ix);
2172 14         34 my $and_node_id =
2173             $order->_marpa_o_and_node_order_get( $or_node_id, $choice );
2174 14         18 my $token_name;
2175 14 50       26 if ( defined $token_id ) {
2176 14         38 $token_name = $grammar->symbol_name($token_id);
2177             }
2178              
2179 14 50       22 print {$Marpa::R2::Internal::TRACE_FH}
  14 50       46  
2180             'Pushed value from ',
2181             Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ),
2182             ': ',
2183             ( $token_name ? qq{$token_name = } : q{} ),
2184             Data::Dumper->new( [ \$token_value ] )->Terse(1)->Dump
2185             or Marpa::R2::exception('print to trace handle failed');
2186              
2187 14         696 return;
2188              
2189             } ## end sub trace_token_evaluation
2190              
2191             sub trace_stack_1 {
2192 18     18   38 my ( $grammar, $recce, $value, $args, $rule_id ) = @_;
2193 18         32 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
2194 18         26 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
2195 18         24 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
2196 18         27 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
2197              
2198 18         39 my $argc = scalar @{$args};
  18         39  
2199 18         46 my $nook_ix = $value->_marpa_v_nook();
2200 18         46 my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix);
2201 18         42 my $choice = $tree->_marpa_t_nook_choice($nook_ix);
2202 18         42 my $and_node_id =
2203             $order->_marpa_o_and_node_order_get( $or_node_id, $choice );
2204              
2205 18         38 return 'Popping ', $argc,
2206             ' values to evaluate ',
2207             Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ),
2208             ', rule: ', $grammar->brief_rule($rule_id);
2209              
2210             } ## end sub trace_stack_1
2211              
2212             sub trace_op {
2213              
2214 49     49   84 my ( $grammar, $recce, $value ) = @_;
2215              
2216 49         74 my $trace_output = q{};
2217 49   50     99 my $trace_values =
2218             $recce->[Marpa::R2::Internal::Recognizer::TRACE_VALUES] // 0;
2219              
2220 49 100       108 return $trace_output if not $trace_values >= 2;
2221              
2222 32         45 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
2223 32         42 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
2224 32         46 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
2225 32         41 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
2226              
2227 32         93 my $nook_ix = $value->_marpa_v_nook();
2228 32         114 my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix);
2229 32         67 my $choice = $tree->_marpa_t_nook_choice($nook_ix);
2230 32         71 my $and_node_id =
2231             $order->_marpa_o_and_node_order_get( $or_node_id, $choice );
2232 32         67 my $trace_irl_id = $bocage->_marpa_b_or_node_irl($or_node_id);
2233 32         79 my $virtual_rhs = $grammar_c->_marpa_g_irl_is_virtual_rhs($trace_irl_id);
2234 32         62 my $virtual_lhs = $grammar_c->_marpa_g_irl_is_virtual_lhs($trace_irl_id);
2235              
2236 32 100       117 return $trace_output
2237             if $bocage->_marpa_b_or_node_position($or_node_id)
2238             != $grammar_c->_marpa_g_irl_length($trace_irl_id);
2239              
2240 20 100 66     118 return $trace_output if not $virtual_rhs and not $virtual_lhs;
2241              
2242 2 50 33     17 if ( $virtual_rhs and not $virtual_lhs ) {
2243              
2244 0 0       0 $trace_output .= join q{},
2245             'Head of Virtual Rule: ',
2246             Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ),
2247             ', rule: ', $grammar->brief_irl($trace_irl_id),
2248             "\n",
2249             'Incrementing virtual rule by ',
2250             $grammar_c->_marpa_g_real_symbol_count($trace_irl_id), ' symbols',
2251             "\n"
2252             or Marpa::R2::exception('Could not print to trace file');
2253              
2254 0         0 return $trace_output;
2255              
2256             } ## end if ( $virtual_rhs and not $virtual_lhs )
2257              
2258 2 50 33     11 if ( $virtual_lhs and $virtual_rhs ) {
2259              
2260 0         0 $trace_output .= join q{},
2261             'Virtual Rule: ',
2262             Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ),
2263             ', rule: ', $grammar->brief_irl($trace_irl_id),
2264             "\nAdding ",
2265             $grammar_c->_marpa_g_real_symbol_count($trace_irl_id),
2266             "\n";
2267              
2268 0         0 return $trace_output;
2269              
2270             } ## end if ( $virtual_lhs and $virtual_rhs )
2271              
2272 2 50 33     13 if ( not $virtual_rhs and $virtual_lhs ) {
2273              
2274 2         7 $trace_output .= join q{},
2275             'New Virtual Rule: ',
2276             Marpa::R2::Recognizer::and_node_tag( $recce, $and_node_id ),
2277             ', rule: ', $grammar->brief_irl($trace_irl_id),
2278             "\nReal symbol count is ",
2279             $grammar_c->_marpa_g_real_symbol_count($trace_irl_id),
2280             "\n";
2281              
2282 2         9 return $trace_output;
2283              
2284             } ## end if ( not $virtual_rhs and $virtual_lhs )
2285              
2286 0         0 return $trace_output;
2287             } ## end sub trace_op
2288              
2289             sub value_trace {
2290 7952     7952   14910 my ( $value, $trace_flag ) = @_;
2291 7952         20815 return $value->_marpa_v_trace($trace_flag);
2292             }
2293              
2294             1;
2295              
2296             # vim: expandtab shiftwidth=4: