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   2743 use 5.010001;
  135         519  
19 135     135   848 use warnings;
  135         319  
  135         5182  
20 135     135   945 use strict;
  135         392  
  135         4707  
21              
22 135     135   853 use vars qw($VERSION $STRING_VERSION);
  135         369  
  135         13263  
23             $VERSION = '13.002_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   1069 use English qw( -no_match_vars );
  135         374  
  135         1044  
32              
33 135     135   51480 use constant SKIP => -1;
  135         354  
  135         66711  
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   47797 my ( $recce, $closure_name, $p_error ) = @_;
48 30324         40668 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
49 30324         39946 my $closures = $recce->[Marpa::R2::Internal::Recognizer::CLOSURES];
50 30324         39349 my $trace_actions =
51             $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS];
52              
53             # A reserved closure name;
54 30324 100       51550 return [ q{}, undef, '::!default' ] if not defined $closure_name;
55              
56 29315 50       48706 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       46746 return [ q{}, \undef, $closure_name ] if $closure_name eq '::undef';
63 29299 100 100     88057 if ( substr( $closure_name, 0, 2 ) eq q{::}
64             or substr( $closure_name, 0, 1 ) eq '[' )
65             {
66 24841         55625 return [ q{}, undef, $closure_name ];
67             }
68              
69 4458 100       10301 if ( my $closure = $closures->{$closure_name} ) {
70 2994 50       4453 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         6649 return [ $closure_name, $closure, '::array' ];
77             } ## end if ( my $closure = $closures->{$closure_name} )
78              
79 1464         1983 my $fully_qualified_name;
80 1464 100       6522 if ( $closure_name =~ /([:][:])|[']/xms ) {
81 800         1381 $fully_qualified_name = $closure_name;
82             }
83              
84 1464 100       2996 if ( not $fully_qualified_name ) {
85 664         1086 my $resolve_package =
86             $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE];
87 664 50       1298 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         1544 $fully_qualified_name = $resolve_package . q{::} . $closure_name;
101             } ## end if ( not $fully_qualified_name )
102              
103 1464         2377 my $closure;
104             my $type;
105             TYPE: {
106 135     135   1169 no strict 'refs';
  135         293  
  135         7121  
  1464         1977  
107 1464         1965 $closure = *{$fully_qualified_name}{'CODE'};
  1464         4767  
108 135     135   1003 use strict;
  135         449  
  135         6478  
109 1464 100       3246 if ( defined $closure ) {
110 1300         1897 $type = 'CODE';
111 1300         2104 last TYPE;
112             }
113 135     135   983 no strict 'refs';
  135         376  
  135         6558  
114 164         240 $closure = *{$fully_qualified_name}{'SCALAR'};
  164         407  
115 135     135   883 use strict;
  135         374  
  135         16606  
116              
117             # Currently $closure is always defined, but this
118             # behavior is said to be subject to change in perlref
119 164 100 66     484 if ( defined $closure and defined ${$closure} ) {
  164         501  
120 35         65 $type = 'SCALAR';
121 35         59 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         245 $closure = undef;
133             } ## end TYPE:
134              
135 1464 100       3099 if ( defined $closure ) {
136 1335 50       2490 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         3998 return [ $fully_qualified_name, $closure, '::array' ];
143             } ## end if ( defined $closure )
144              
145 129 50 33     463 if ( $trace_actions or defined $p_error ) {
146 129         295 for my $slot (qw(ARRAY HASH IO FORMAT)) {
147 135     135   989 no strict 'refs';
  135         350  
  135         1749001  
148 516 50       663 if ( defined *{$fully_qualified_name}{$slot} ) {
  516         1348  
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         422  
165             qq{Failed resolution of action "$closure_name" to $fully_qualified_name\n};
166 129 50       377 ${$p_error} = $error if defined $p_error;
  129         229  
167 129 50       326 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         339 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   59728 my ( $recce, $lexeme_id ) = @_;
179 41499         53342 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
180 41499         51255 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
181 41499         61403 my $symbol = $symbols->[$lexeme_id];
182 41499         58919 my $semantics = $symbol->[Marpa::R2::Internal::Symbol::LEXEME_SEMANTICS];
183 41499 100       83531 return '::!default' if not defined $semantics;
184 3959         6729 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   59801 my ( $recce, $rule_id ) = @_;
190 31364         42252 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
191 31364         39629 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
192 31364         38918 my $rule = $rules->[$rule_id];
193 31364         52202 my $blessing = $rule->[Marpa::R2::Internal::Rule::BLESSING];
194 31364 100       51643 $blessing = '::undef' if not defined $blessing;
195 31364 100       66336 return $blessing if $blessing eq '::undef';
196 22493         29996 my $bless_package =
197             $grammar->[Marpa::R2::Internal::Grammar::BLESS_PACKAGE];
198              
199 22493 50       36847 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         63179 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   59073 my ( $recce, $lexeme_id ) = @_;
210 41499         53164 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
211 41499         50850 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
212 41499         51113 my $symbol = $symbols->[$lexeme_id];
213 41499         53465 my $blessing = $symbol->[Marpa::R2::Internal::Symbol::BLESSING];
214              
215 41499 100       81905 return '::undef' if not defined $blessing;
216 3710 50       6766 return '::undef' if $blessing eq '::undef';
217 3710 50       7314 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       6907 if ( $blessing =~ m/ [:][:] /xms ) {
225 0         0 return $blessing;
226             }
227 3710         5421 my $bless_package =
228             $grammar->[Marpa::R2::Internal::Grammar::BLESS_PACKAGE];
229 3710 50       6288 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         9785 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   56 if ( scalar @_ == 1 and ref $_[0] ) {
252 2         23 die bless { exception_object => $_[0] }, $CONTEXT_EXCEPTION_CLASS;
253             }
254 2         10 my $error_string = join q{}, @_;
255 2         8 my ( $package, $filename, $line ) = caller;
256 2         7 chomp $error_string;
257 2         45 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   27 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         16 return $valuator->location();
269             } ## end sub Marpa::R2::Context::location
270              
271             sub code_problems {
272 10     10   27 my $args = shift;
273              
274 10         19 my $grammar;
275             my $fatal_error;
276 10         19 my $warnings = [];
277 10         20 my $where = '?where?';
278 10         15 my $long_where;
279 10         19 my @msg = ();
280 10         15 my $eval_value;
281 10         17 my $eval_given = 0;
282              
283 10         22 push @msg, q{=} x 60, "\n";
284 10         16 ARG: for my $arg ( keys %{$args} ) {
  10         47  
285 60         97 my $value = $args->{$arg};
286 60 100       121 if ( $arg eq 'fatal_error' ) { $fatal_error = $value; next ARG }
  10         18  
  10         24  
287 50 100       93 if ( $arg eq 'grammar' ) { $grammar = $value; next ARG }
  10         14  
  10         18  
288 40 100       73 if ( $arg eq 'where' ) { $where = $value; next ARG }
  10         14  
  10         17  
289 30 100       58 if ( $arg eq 'long_where' ) { $long_where = $value; next ARG }
  10         17  
  10         17  
290 20 100       40 if ( $arg eq 'warnings' ) { $warnings = $value; next ARG }
  10         19  
  10         16  
291 10 50       27 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         21 my $fatal_error_ref_type = ref $fatal_error;
  10         34  
301 10 100       24 last GIVEN_FATAL_ERROR_REF_TYPE if not $fatal_error_ref_type;
302 4 50       11 if ( $fatal_error_ref_type eq $CONTEXT_EXCEPTION_CLASS ) {
303 4         9 my $exception_object = $fatal_error->{exception_object};
304 4 100       98 die $exception_object if defined $exception_object;
305 2         7 my $exception_message = $fatal_error->{message};
306 2 50       62 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         22 my @problem_line = ();
318 6         11 my $max_problem_line = -1;
319 6         8 for my $warning_data ( @{$warnings} ) {
  6         14  
320             my ( $warning, $package, $filename, $problem_line ) =
321 4         5 @{$warning_data};
  4         10  
322 4         8 $problem_line[$problem_line] = 1;
323 4         17 $max_problem_line = List::Util::max $problem_line, $max_problem_line;
324             } ## end for my $warning_data ( @{$warnings} )
325              
326 6   33     14 $long_where //= $where;
327              
328 6         9 my $warnings_count = scalar @{$warnings};
  6         11  
329             {
330 6         8 my @problems;
  6         9  
331 6   66     48 my $false_eval = $eval_given && !$eval_value && !$fatal_error;
332 6 50       16 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       12 if ($fatal_error) {
337 4         9 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       13 if ( not scalar @problems ) {
345 0         0 push @msg, '* THERE WAS A FATAL PROBLEM IN THE MARPA SEMANTICS';
346             }
347 6         28 push @msg, ( join "\n", @problems ) . "\n";
348             }
349              
350 6         15 push @msg, "* THIS IS WHAT MARPA WAS DOING WHEN THE PROBLEM OCCURRED:\n"
351             . $long_where . "\n";
352              
353 6         16 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         42 $warning_message =~ s/\n*\z/\n/xms;
357 4         9 push @msg, $warning_message;
358             } ## end for my $warning_ix ( 0 .. ( $warnings_count - 1 ) )
359              
360 6 100       15 if ($fatal_error) {
361 4         9 push @msg, "* THIS WAS THE FATAL ERROR MESSAGE:\n";
362 4         7 my $fatal_error_message = $fatal_error;
363 4         48 $fatal_error_message =~ s/\n*\z/\n/xms;
364 4         11 push @msg, $fatal_error_message;
365             } ## end if ($fatal_error)
366              
367 6         22 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 2884 my ($recce) = @_;
428 1410 50       3391 return if $recce->[Marpa::R2::Internal::Recognizer::NO_PARSE];
429 1410         2346 my $ordering = $recce->[Marpa::R2::Internal::Recognizer::O_C];
430 1410 100       3199 return $ordering if $ordering;
431 1188         2027 my $parse_set_arg =
432             $recce->[Marpa::R2::Internal::Recognizer::END_OF_PARSE];
433 1188         1887 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
434 1188         1937 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
435 1188         1956 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
436              
437 1188         3876 $grammar_c->throw_set(0);
438 1188   100     54291 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C] =
439             Marpa::R2::Thin::B->new( $recce_c, ( $parse_set_arg // -1 ) );
440 1188         4506 $grammar_c->throw_set(1);
441 1188 100       3933 if ( not $bocage ) {
442 20         52 $recce->[Marpa::R2::Internal::Recognizer::NO_PARSE] = 1;
443 20         56 return;
444             }
445 1168         5360 $ordering = $recce->[Marpa::R2::Internal::Recognizer::O_C] =
446             Marpa::R2::Thin::O->new($bocage);
447              
448             GIVEN_RANKING_METHOD: {
449 1168         2123 my $ranking_method =
  1168         2309  
450             $recce->[Marpa::R2::Internal::Recognizer::RANKING_METHOD];
451 1168 100       3084 if ( $ranking_method eq 'high_rule_only' ) {
452 95         278 do_high_rule_only($recce);
453 95         200 last GIVEN_RANKING_METHOD;
454             }
455 1073 100       2945 if ( $ranking_method eq 'rule' ) {
456 8         59 do_rank_by_rule($recce);
457 8         18 last GIVEN_RANKING_METHOD;
458             }
459             } ## end GIVEN_RANKING_METHOD:
460              
461 1168         2977 return $ordering;
462             } ## end sub Marpa::R2::Recognizer::ordering_get
463              
464             sub resolve_rule_by_id {
465 31365     31365   46619 my ( $recce, $rule_id ) = @_;
466 31365         41772 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
467 31365         40204 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
468 31365         45823 my $rule = $rules->[$rule_id];
469 31365         64033 my $action_name = $rule->[Marpa::R2::Internal::Rule::ACTION_NAME];
470 31365         37944 my $resolve_error;
471 31365 100       53578 return if not defined $action_name;
472 28957         46018 my $resolution = Marpa::R2::Internal::Recognizer::resolve_action( $recce,
473             $action_name, \$resolve_error );
474              
475 28957 100       54684 if ( not $resolution ) {
476 1         5 my $rule_desc = rule_describe( $grammar, $rule_id );
477 1   50     9 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         46406 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   5 my ( $grammar, $rule_id ) = @_;
491 1 50       9 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   2329 my ( $recce, $per_parse_arg ) = @_;
499 1168         2018 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
500 1168         1913 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
501 1168         1823 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
502 1168         2234 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
503              
504 1168   50     3683 my $trace_actions =
505             $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0;
506 1168         2561 my $trace_file_handle =
507             $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE];
508              
509 1168         2164 my $package_source =
510             $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE];
511 1168 100 100     5592 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         169 $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE] =
516             $arg_blessing;
517 80         161 $package_source = 'arg';
518             } ## end if ( not defined $package_source and defined $per_parse_arg...)
519 1168   100     4209 $package_source //= 'semantics_package';
520 1168         2505 $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE] =
521             $package_source;
522              
523 1168 100       2977 if ( $package_source eq 'legacy' ) {
524              
525             # RESOLVE_PACKAGE is already set if not 'legacy'
526 237   100     915 $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       1885 my $constructor_package =
  1168         3103  
533             ( $package_source eq 'legacy' )
534             ? $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT]
535             : $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE];
536 1168 100       3347 last FIND_CONSTRUCTOR if not defined $constructor_package;
537 189         593 my $constructor_name = $constructor_package . q{::new};
538 189         312 my $resolve_error;
539 189         596 my $resolution =
540             Marpa::R2::Internal::Recognizer::resolve_action( $recce,
541             $constructor_name, \$resolve_error );
542 189 100       487 if ($resolution) {
543 61         145 $recce->[ Marpa::R2::Internal::Recognizer::PER_PARSE_CONSTRUCTOR ]
544             = $resolution->[1];
545 61         202 last FIND_CONSTRUCTOR;
546             }
547 128 50       403 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         1884 my $resolve_error;
554              
555 1168         2082 my $default_action =
556             $grammar->[Marpa::R2::Internal::Grammar::DEFAULT_ACTION];
557 1168         3504 my $default_action_resolution =
558             Marpa::R2::Internal::Recognizer::resolve_action( $recce,
559             $default_action, \$resolve_error );
560 1168 50 0     3103 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         2387 my $default_empty_action =
566             $grammar->[Marpa::R2::Internal::Grammar::DEFAULT_EMPTY_ACTION];
567 1168         1809 my $default_empty_action_resolution;
568 1168 100       2606 if ($default_empty_action) {
569 10         36 $default_empty_action_resolution =
570             Marpa::R2::Internal::Recognizer::resolve_action( $recce,
571             $default_empty_action, \$resolve_error );
572 10 50 0     30 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         2185 my $rule_resolutions = [];
580              
581 1168         4516 RULE: for my $rule_id ( $grammar->rule_ids() ) {
582              
583 31365         49462 my $rule_resolution = resolve_rule_by_id( $recce, $rule_id );
584 31364 100 100     62751 if ( not defined $rule_resolution
      100        
585             and $default_empty_action
586             and $grammar_c->rule_length($rule_id) == 0 )
587             {
588 13         27 $rule_resolution = $default_empty_action_resolution;
589             } ## end if ( not defined $rule_resolution and $default_empty_action...)
590              
591 31364   66     55523 $rule_resolution //= $default_action_resolution;
592              
593 31364 50       50440 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         37826 my $blessing =
  31364         48179  
610             Marpa::R2::Internal::Recognizer::rule_blessing_find( $recce,
611             $rule_id );
612 31364         43308 my ( $closure_name, $closure, $semantics ) = @{$rule_resolution};
  31364         52716  
613              
614 31364 100       56847 if ( $blessing ne '::undef' ) {
615 22493 50       36746 $semantics = '::array' if $semantics eq '::!default';
616             CHECK_SEMANTICS: {
617 22493 100       27141 last CHECK_SEMANTICS if $semantics eq '::array';
  22493         36514  
618             last CHECK_SEMANTICS
619 22399 50       43483 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         78293 [ $closure_name, $closure, $semantics, $blessing ];
628             } ## end DETERMINE_BLESSING:
629              
630 31364         57571 $rule_resolutions->[$rule_id] = $rule_resolution;
631              
632             } ## end RULE: for my $rule_id ( $grammar->rule_ids() )
633              
634 1167 50       4045 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         2487 my @lexeme_resolutions = ();
646 1167         1902 SYMBOL: for my $lexeme_id ( 0 .. $#{$symbols} ) {
  1167         4111  
647 41499         59744 my $semantics =
648             Marpa::R2::Internal::Recognizer::lexeme_semantics_find( $recce,
649             $lexeme_id );
650 41499 50       70551 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         57940 my $blessing =
661             Marpa::R2::Internal::Recognizer::lexeme_blessing_find( $recce,
662             $lexeme_id );
663 41499 50       70530 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         88347 $lexeme_resolutions[$lexeme_id] = [ $semantics, $blessing ];
674              
675             } ## end SYMBOL: for my $lexeme_id ( 0 .. $#{$symbols} )
676              
677 1167         5925 return ( $rule_resolutions, \@lexeme_resolutions );
678             } ## end sub resolve_recce
679              
680             sub registration_init {
681 1119     1119   2645 my ( $recce, $per_parse_arg ) = @_;
682              
683 1119         2949 my $trace_file_handle =
684             $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE];
685 1119         1913 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
686 1119         1932 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
687 1119         1780 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
688 1119         1937 my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER];
689 1119   50     3963 my $trace_actions =
690             $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0;
691 1119         1945 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
692 1119         1875 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
693              
694 1119         2019 my @closure_by_rule_id = ();
695 1119         1775 my @semantics_by_rule_id = ();
696 1119         1663 my @blessing_by_rule_id = ();
697              
698 1119         3018 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         2141 RULE:
708 1118         4139 for my $rule_id ( $grammar->rule_ids() ) {
709             my ( $new_resolution, $closure, $semantics, $blessing ) =
710 30996         39070 @{ $rule_resolutions->[$rule_id] };
  30996         61133  
711 30996         63114 my $lhs_id = $grammar_c->rule_lhs($rule_id);
712              
713             REFINE_SEMANTICS: {
714              
715 30996 100 66     39396 if ('[' eq substr $semantics,
  30996         85672  
716             0, 1 and ']' eq substr $semantics,
717             -1, 1
718             )
719             {
720             # Normalize array semantics
721 22974         214241 $semantics =~ s/ //gxms;
722 22974         37229 last REFINE_SEMANTICS;
723             } ## end if ( '[' eq substr $semantics, 0, 1 and ']' eq ...)
724              
725             state $allowed_semantics = {
726 8022         10874 map { ; ( $_, 1 ) }
  702         2330  
727             qw(::array ::undef ::first ::whatever ::!default),
728             q{}
729             };
730 8022 50       15927 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         49102 $semantics_by_rule_id[$rule_id] = $semantics;
744 30996         42208 $blessing_by_rule_id[$rule_id] = $blessing;
745 30996         41401 $closure_by_rule_id[$rule_id] = $closure;
746              
747             CHECK_BLESSING: {
748 30996 100       36442 last CHECK_BLESSING if $blessing eq '::undef';
  30996         56399  
749 22373 50       35023 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       34713 last CHECK_BLESSING if $semantics eq '::array';
769 22279 50       48743 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         3122 my @nullable_rule_ids_by_lhs = ();
788 1118         3363 RULE: for my $rule_id ( $grammar->rule_ids() ) {
789 30996         47575 my $lhs_id = $grammar_c->rule_lhs($rule_id);
790 30996 100       64393 push @{ $nullable_rule_ids_by_lhs[$lhs_id] }, $rule_id
  2122         5780  
791             if $grammar_c->rule_is_nullable($rule_id);
792             }
793              
794 1118         2687 my @null_symbol_closures;
795             LHS:
796 1118         3620 for ( my $lhs_id = 0; $lhs_id <= $#nullable_rule_ids_by_lhs; $lhs_id++ ) {
797 31648         39546 my $rule_ids = $nullable_rule_ids_by_lhs[$lhs_id];
798 31648         37005 my $resolution_rule;
799              
800             # No nullable rules for this LHS? No problem.
801 31648 100       64236 next LHS if not defined $rule_ids;
802 2112         3050 my $rule_count = scalar @{$rule_ids};
  2112         3369  
803              
804             # I am not sure if this test is necessary
805 2112 50       4396 next LHS if $rule_count <= 0;
806              
807             # Just one nullable rule? Then that's our semantics.
808 2112 100       4080 if ( $rule_count == 1 ) {
809 2102         3077 $resolution_rule = $rule_ids->[0];
810             my ( $resolution_name, $closure ) =
811 2102         2832 @{ $rule_resolutions->[$resolution_rule] };
  2102         4093  
812 2102 50       3969 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         3993 $null_symbol_closures[$lhs_id] = $resolution_rule;
821 2102         5097 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         29 grep { $grammar_c->rule_length($_) <= 0 } @{$rule_ids};
  20         140  
  10         26  
828 10 100       55 if ( scalar @empty_rules ) {
829 9         15 $resolution_rule = $empty_rules[0];
830             my ( $resolution_name, $closure ) =
831 9         15 @{ $rule_resolutions->[$resolution_rule] };
  9         28  
832 9 50       32 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         18 $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         3  
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         2 = @{$first_resolution};
  1         6  
852 1         3 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         4  
856              
857 1 50 33     12 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         2 $resolution_rule = $rule_ids->[0];
877             my ( $resolution_name, $closure ) =
878 1         2 @{ $rule_resolutions->[$resolution_rule] };
  1         3  
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         6 $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         2631 $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES] =
895             \@null_symbol_closures;
896              
897 1118         2076 my @semantics_by_lexeme_id = ();
898 1118         1867 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         1809 LEXEME: for my $lexeme_id ( 0 .. $#{$symbols} ) {
  1118         1735  
  1118         2822  
905              
906             my ( $semantics, $blessing ) =
907 41075         48970 @{ $lexeme_resolutions->[$lexeme_id] };
  41075         67356  
908             CHECK_SEMANTICS: {
909 41075 50       51506 if ( not $semantics ) {
  41075         64854  
910 0         0 $semantics = '::!default';
911 0         0 last CHECK_SEMANTICS;
912             }
913 41075 100       72377 if ( ( substr $semantics, 0, 1 ) eq '[' ) {
914 3933         40363 $semantics =~ s/ //gxms;
915 3933         6614 last CHECK_SEMANTICS;
916             }
917             state $allowed_semantics =
918 37142         43654 { map { ; ( $_, 1 ) } qw(::array ::undef ::!default ) };
  351         1071  
919              
920 37142 50       65879 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       48899 if ( not $blessing ) {
  41075         62201  
932 0         0 $blessing = '::undef';
933 0         0 last CHECK_BLESSING;
934             }
935 41075 100       68905 last CHECK_BLESSING if $blessing eq '::undef';
936             last CHECK_BLESSING
937 3686 50       12607 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         59830 $semantics_by_lexeme_id[$lexeme_id] = $semantics;
946 41075         66742 $blessing_by_lexeme_id[$lexeme_id] = $blessing;
947              
948             } ## end LEXEME: for my $lexeme_id ( 0 .. $#{$symbols} )
949              
950             }
951              
952 1118         2487 my $null_values = $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES];
953              
954 1118         2422 state $op_bless = Marpa::R2::Thin::op('bless');
955 1118         1983 state $op_callback = Marpa::R2::Thin::op('callback');
956 1118         1958 state $op_push_constant = Marpa::R2::Thin::op('push_constant');
957 1118         1830 state $op_push_g1_length = Marpa::R2::Thin::op('push_g1_length');
958 1118         1842 state $op_push_g1_len = Marpa::R2::Thin::op('push_g1_len');
959 1118         1944 state $op_push_length = Marpa::R2::Thin::op('push_length');
960 1118         2077 state $op_push_undef = Marpa::R2::Thin::op('push_undef');
961 1118         1791 state $op_push_one = Marpa::R2::Thin::op('push_one');
962 1118         2312 state $op_push_sequence = Marpa::R2::Thin::op('push_sequence');
963 1118         1782 state $op_push_g1_start = Marpa::R2::Thin::op('push_g1_start');
964 1118         3566 state $op_push_start_location =
965             Marpa::R2::Thin::op('push_start_location');
966 1118         1834 state $op_push_values = Marpa::R2::Thin::op('push_values');
967 1118         1830 state $op_result_is_array = Marpa::R2::Thin::op('result_is_array');
968 1118         1826 state $op_result_is_constant = Marpa::R2::Thin::op('result_is_constant');
969 1118         1861 state $op_result_is_n_of_sequence =
970             Marpa::R2::Thin::op('result_is_n_of_sequence');
971 1118         1920 state $op_result_is_rhs_n = Marpa::R2::Thin::op('result_is_rhs_n');
972 1118         1960 state $op_result_is_token_value =
973             Marpa::R2::Thin::op('result_is_token_value');
974 1118         1848 state $op_result_is_undef = Marpa::R2::Thin::op('result_is_undef');
975              
976 1118         1653 my @nulling_symbol_by_semantic_rule;
977 1118         1685 NULLING_SYMBOL: for my $nulling_symbol ( 0 .. $#{$null_values} ) {
  1118         2840  
978 31648         39174 my $semantic_rule = $null_values->[$nulling_symbol];
979 31648 100       53427 next NULLING_SYMBOL if not defined $semantic_rule;
980 2112         4169 $nulling_symbol_by_semantic_rule[$semantic_rule] = $nulling_symbol;
981             } ## end NULLING_SYMBOL: for my $nulling_symbol ( 0 .. $#{$null_values} )
982              
983 1118         2534 my @work_list = ();
984 1118         3910 RULE: for my $rule_id ( $grammar->rule_ids() ) {
985              
986 30996         41930 my $semantics = $semantics_by_rule_id[$rule_id];
987 30996         39695 my $blessing = $blessing_by_rule_id[$rule_id];
988              
989 30996 100       49741 $semantics = '::undef' if $semantics eq '::!default';
990 30996 100       48148 $semantics = '[values]' if $semantics eq '::array';
991 30996 100       47776 $semantics = '::undef' if $semantics eq '::whatever';
992 30996 100       48263 $semantics = '::rhs0' if $semantics eq '::first';
993              
994 30996         70441 push @work_list, [ $rule_id, undef, $semantics, $blessing ];
995             } ## end RULE: for my $rule_id ( $grammar->rule_ids() )
996              
997 1118         2707 RULE: for my $lexeme_id ( 0 .. $#{$symbols} ) {
  1118         2796  
998              
999 41075         55173 my $semantics = $semantics_by_lexeme_id[$lexeme_id];
1000 41075         50773 my $blessing = $blessing_by_lexeme_id[$lexeme_id];
1001              
1002 41075 100       67866 $semantics = '::value' if $semantics eq '::!default';
1003 41075 50       64305 $semantics = '[value]' if $semantics eq '::array';
1004              
1005 41075         94099 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         2461 my @nulling_closures = ();
1012 1118         1945 my @registrations = ();
1013 1118         1878 my $top_nulling_ops;
1014              
1015 1118         2230 WORK_ITEM: for my $work_item (@work_list) {
1016 72071         92282 my ( $rule_id, $lexeme_id, $semantics, $blessing ) = @{$work_item};
  72071         136646  
1017              
1018 72071         102833 my ( $closure, $rule, $rule_length, $is_sequence_rule,
1019             $is_discard_sequence_rule, $nulling_symbol_id );
1020 72071 100       121106 if ( defined $rule_id ) {
1021 30996         43385 $nulling_symbol_id = $nulling_symbol_by_semantic_rule[$rule_id];
1022 30996         40308 $closure = $closure_by_rule_id[$rule_id];
1023 30996         43624 $rule = $rules->[$rule_id];
1024 30996         72540 $rule_length = $grammar_c->rule_length($rule_id);
1025 30996         64474 $is_sequence_rule = defined $grammar_c->sequence_min($rule_id);
1026 30996   100     61306 $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         88070 my $array_fate;
1032             ARRAY_FATE: {
1033 72071 100 100     88277 if ( defined $closure and ref $closure eq 'CODE' ) {
  72071         132216  
1034 4569         6231 $array_fate = $op_callback;
1035 4569         6479 last ARRAY_FATE;
1036              
1037             }
1038              
1039 67502 100       130183 if ( ( substr $semantics, 0, 1 ) eq '[' ) {
1040 27370         35060 $array_fate = $op_result_is_array;
1041 27370         38577 last ARRAY_FATE;
1042             }
1043             } ## end ARRAY_FATE:
1044              
1045 72071         95449 my @ops = ();
1046              
1047             SET_OPS: {
1048              
1049 72071 100       87759 if ( $semantics eq '::undef' ) {
  72071         120883  
1050 1768         2569 @ops = ($op_result_is_undef);
1051 1768         2416 last SET_OPS;
1052             }
1053              
1054             DO_CONSTANT: {
1055 70303 100       84717 last DO_CONSTANT if not defined $rule_id;
  70303         120486  
1056 29228         41011 my $thingy_ref = $closure_by_rule_id[$rule_id];
1057 29228 100       52759 last DO_CONSTANT if not defined $thingy_ref;
1058 4604         9644 my $ref_type = Scalar::Util::reftype $thingy_ref;
1059 4604 50       8046 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       7998 if ( $ref_type eq 'CODE' ) {
1070              
1071             # Set the nulling closure if this is the nulling symbol of a rule
1072 4569 100 66     9349 $nulling_closures[$nulling_symbol_id] = $thingy_ref
1073             if defined $nulling_symbol_id
1074             and defined $rule_id;
1075 4569         6794 last DO_CONSTANT;
1076             } ## end if ( $ref_type eq 'CODE' )
1077 35 100       83 if ( $ref_type eq 'SCALAR' ) {
1078 30         42 my $thingy = ${$thingy_ref};
  30         64  
1079 30 50       71 if ( not defined $thingy ) {
1080 0         0 @ops = ($op_result_is_undef);
1081 0         0 last SET_OPS;
1082             }
1083 30         51 @ops = ( $op_result_is_constant, $thingy_ref );
1084 30         57 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       9 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     162478 if ( defined $lexeme_id and $semantics eq '::value' ) {
1107 37142         52961 @ops = ($op_result_is_token_value);
1108 37142         48658 last SET_OPS;
1109             }
1110              
1111             PROCESS_SINGLETON_RESULT: {
1112 33126 100       40843 last PROCESS_SINGLETON_RESULT if not defined $rule_id;
  33126         53314  
1113              
1114 29193         36260 my $singleton;
1115 29193 100       59762 if ( $semantics =~ m/\A [:][:] rhs (\d+) \z/xms ) {
1116 1222         4647 $singleton = $1 + 0;
1117             }
1118              
1119 29193 100       52002 last PROCESS_SINGLETON_RESULT if not defined $singleton;
1120              
1121 1222         2003 my $singleton_element = $singleton;
1122 1222 50       2605 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       2486 if ($is_sequence_rule) {
1128 0         0 @ops = ( $op_result_is_rhs_n, $singleton_element );
1129 0         0 last SET_OPS;
1130             }
1131 1222         2226 my $mask = $rule->[Marpa::R2::Internal::Rule::MASK];
1132             my @elements =
1133 1222         2884 grep { $mask->[$_] } 0 .. ( $rule_length - 1 );
  1252         3612  
1134 1222 50       2985 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         2012 $singleton_element = $elements[$singleton];
1144              
1145 1222 50       2641 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         2186 @ops = ( $op_result_is_rhs_n, $singleton_element );
1155 1222         2521 last SET_OPS;
1156             } ## end PROCESS_SINGLETON_RESULT:
1157              
1158 31904 50       52168 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         43354 my @bless_ops = ();
1166 31904 100       55503 if ( $blessing ne '::undef' ) {
1167 26059         42021 push @bless_ops, $op_bless, \$blessing;
1168             }
1169              
1170 31904 50       64581 Marpa::R2::exception(qq{Unknown semantics: "$semantics"})
1171             if ( substr $semantics, 0, 1 ) ne '[';
1172              
1173 31904         41902 my @push_ops = ();
1174 31904         51160 my $array_descriptor = substr $semantics, 1, -1;
1175 31904         221284 $array_descriptor =~ s/^\s*|\s*$//g;
1176             RESULT_DESCRIPTOR:
1177 31904         121008 for my $result_descriptor ( split /[,]\s*/xms, $array_descriptor )
1178             {
1179 85959         345309 $result_descriptor =~ s/^\s*|\s*$//g;
1180 85959 100       168760 if ( $result_descriptor eq 'g1start' ) {
1181 562         911 push @push_ops, $op_push_g1_start;
1182 562         965 next RESULT_DESCRIPTOR;
1183             }
1184 85397 100       137705 if ( $result_descriptor eq 'g1len' ) {
1185 562         906 push @push_ops, $op_push_g1_len;
1186 562         863 next RESULT_DESCRIPTOR;
1187             }
1188 84835 100       133201 if ( $result_descriptor eq 'g1length' ) {
1189 4         10 push @push_ops, $op_push_g1_length;
1190 4         6 next RESULT_DESCRIPTOR;
1191             }
1192 84831 100       135602 if ( $result_descriptor eq 'start' ) {
1193 26108         38442 push @push_ops, $op_push_start_location;
1194 26108         40868 next RESULT_DESCRIPTOR;
1195             }
1196 58723 100       96519 if ( $result_descriptor eq 'length' ) {
1197 26108         36065 push @push_ops, $op_push_length;
1198 26108         39276 next RESULT_DESCRIPTOR;
1199             }
1200              
1201 32615 100       54777 if ( $result_descriptor eq 'lhs' ) {
1202 9 100       28 if ( defined $rule_id ) {
1203 5         1930 my $lhs_id = $grammar_c->rule_lhs($rule_id);
1204 5         17 push @push_ops, $op_push_constant, \$lhs_id;
1205 5         13 next RESULT_DESCRIPTOR;
1206             }
1207 4 50       25 if ( defined $lexeme_id ) {
1208 4         18 push @push_ops, $op_push_constant, \$lexeme_id;
1209 4         10 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       53597 if ( $result_descriptor eq 'name' ) {
1216 705 100       1385 if ( defined $rule_id ) {
1217 654         1890 my $name = $grammar->rule_name($rule_id);
1218 654         1308 push @push_ops, $op_push_constant, \$name;
1219 654         1290 next RESULT_DESCRIPTOR;
1220             }
1221 51 50       129 if ( defined $lexeme_id ) {
1222 51         160 my $name = $tracer->symbol_name($lexeme_id);
1223 51         116 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       53320 if ( $result_descriptor eq 'symbol' ) {
1236 5 100       14 if ( defined $rule_id ) {
1237 3         12 my $lhs_id = $grammar_c->rule_lhs($rule_id);
1238 3         16 my $name = $tracer->symbol_name($lhs_id);
1239 3         10 push @push_ops, $op_push_constant, \$name;
1240 3         5 next RESULT_DESCRIPTOR;
1241             } ## end if ( defined $rule_id )
1242 2 50       10 if ( defined $lexeme_id ) {
1243 2         10 my $name = $tracer->symbol_name($lexeme_id);
1244 2         7 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       52229 if ( $result_descriptor eq 'rule' ) {
1257 5 100       15 if ( defined $rule_id ) {
1258 3         6 push @push_ops, $op_push_constant, \$rule_id;
1259 3         6 next RESULT_DESCRIPTOR;
1260             }
1261 2         15 push @push_ops, $op_push_undef;
1262 2         13 next RESULT_DESCRIPTOR;
1263             } ## end if ( $result_descriptor eq 'rule' )
1264 31891 50 66     66248 if ( $result_descriptor eq 'values'
1265             or $result_descriptor eq 'value' )
1266             {
1267 31891 100       53131 if ( defined $lexeme_id ) {
1268 3933         5507 push @push_ops, $op_push_values;
1269 3933         6550 next RESULT_DESCRIPTOR;
1270             }
1271 27958 100       46710 if ($is_sequence_rule) {
1272 1447 100       3227 my $push_op =
1273             $is_discard_sequence_rule
1274             ? $op_push_sequence
1275             : $op_push_values;
1276 1447         2345 push @push_ops, $push_op;
1277 1447         2888 next RESULT_DESCRIPTOR;
1278             } ## end if ($is_sequence_rule)
1279 26511         49289 my $mask = $rule->[Marpa::R2::Internal::Rule::MASK];
1280 26511 100       46199 if ( $rule_length > 0 ) {
1281             push @push_ops,
1282 25700 100       50810 map { $mask->[$_] ? ( $op_push_one, $_ ) : () }
  50038         137536  
1283             0 .. $rule_length - 1;
1284             }
1285 26511         54967 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         78952 @ops = ( @push_ops, @bless_ops, $array_fate );
1293              
1294             } ## end SET_OPS:
1295              
1296 72071 100       123965 if ( defined $rule_id ) {
1297 30996         86141 push @registrations, [ 'rule', $rule_id, @ops ];
1298             }
1299              
1300 72071 100       120745 if ( defined $nulling_symbol_id ) {
1301              
1302 2112         5061 push @registrations, [ 'nulling', $nulling_symbol_id, @ops ];
1303             } ## end if ( defined $nulling_symbol_id )
1304              
1305 72071 100       134255 if ( defined $lexeme_id ) {
1306 41075         114683 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       2214 last SLR_NULLING_GRAMMAR_HACK if not $Marpa::R2::Context::slr;
  1118         3123  
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         4174 my $start_symbol_id = $tracer->symbol_by_name('[:start]');
1321             last SLR_NULLING_GRAMMAR_HACK
1322 881 100       4355 if not $grammar_c->symbol_is_nullable($start_symbol_id);
1323              
1324 326         568 my $start_rhs_symbol_id;
1325 326         899 RULE: for my $rule_id ( $grammar->rule_ids() ) {
1326 848         2340 my ( $lhs, $rhs0 ) = $tracer->rule_expand($rule_id);
1327 848 100       1987 if ( $start_symbol_id == $lhs ) {
1328 326         472 $start_rhs_symbol_id = $rhs0;
1329 326         620 last RULE;
1330             }
1331             } ## end RULE: for my $rule_id ( $grammar->rule_ids() )
1332              
1333 326         735 REGISTRATION: for my $registration (@registrations) {
1334 704         938 my ( $type, $nulling_symbol_id ) = @{$registration};
  704         1241  
1335 704 100       1415 if ( $nulling_symbol_id == $start_rhs_symbol_id ) {
1336 326         540 my ( undef, undef, @ops ) = @{$registration};
  326         754  
1337 326         1114 push @registrations, [ 'nulling', $start_symbol_id, @ops ];
1338 326         636 $nulling_closures[$start_symbol_id] =
1339             $nulling_closures[$start_rhs_symbol_id];
1340 326         717 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         2561 $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] =
1346             \@registrations;
1347 1118         2005 $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_SYMBOL_ID] =
1348             \@nulling_closures;
1349 1118         40473 $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 69184 my ( $recce, $slr, $per_parse_arg ) = @_;
1357 8082         12879 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
1358 8082         11664 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
1359 8082         11962 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1360 8082         12074 my $tracer = $grammar->[Marpa::R2::Internal::Grammar::TRACER];
1361              
1362 8082   50     26097 my $trace_actions =
1363             $recce->[Marpa::R2::Internal::Recognizer::TRACE_ACTIONS] // 0;
1364 8082   100     21924 my $trace_values =
1365             $recce->[Marpa::R2::Internal::Recognizer::TRACE_VALUES] // 0;
1366 8082         19883 my $trace_file_handle =
1367             $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE];
1368 8082         14579 local $Marpa::R2::Internal::TRACE_FH = $trace_file_handle;
1369              
1370 8082         12869 my $rules = $grammar->[Marpa::R2::Internal::Grammar::RULES];
1371 8082         11948 my $symbols = $grammar->[Marpa::R2::Internal::Grammar::SYMBOLS];
1372              
1373 8082 100       18173 if ( scalar @_ != 1 ) {
1374 5732 50       14526 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     19699 $recce->[Marpa::R2::Internal::Recognizer::TREE_MODE] //= 'tree';
1380 8082 50       16893 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         21929 my $furthest_earleme = $recce_c->furthest_earleme();
1390 8082         19173 my $last_completed_earleme = $recce_c->current_earleme();
1391 8082 50       16856 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         11956 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
1398              
1399 8082 100       16919 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         9227 my $package_source = $recce
  6944         11388  
1405             ->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE];
1406             last CHECK_ARG
1407 6944 100       15871 if $package_source eq 'semantics_package'; # Anything is OK
1408 2114 50       3824 if ( $package_source eq 'legacy' ) {
1409 2114 50       3670 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         3507 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       13712 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         10175 my $max_parses =
1470             $recce->[Marpa::R2::Internal::Recognizer::MAX_PARSES];
1471 6944         16166 my $parse_count = $tree->parse_count();
1472 6944 50 66     18161 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         3205 my $order = $recce->ordering_get();
1482 1138 100       3015 return if not $order;
1483 1118         6235 $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       17155 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       15962 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       15345 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       36460 return if not defined $tree->next();
1504              
1505 7953         13521 local $Marpa::R2::Context::grammar = $grammar;
1506 7953         11286 local $Marpa::R2::Context::rule = undef;
1507 7953         11349 local $Marpa::R2::Context::slr = $slr;
1508 7953 100       16670 local $Marpa::R2::Context::slg =
1509             $slr->[Marpa::R2::Internal::Scanless::R::GRAMMAR]
1510             if defined $slr;
1511              
1512 7953 100       15804 if ( not $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] ) {
1513 1118         3188 registration_init( $recce, $per_parse_arg );
1514             }
1515              
1516 7952         11800 my $semantics_arg0;
1517             RUN_CONSTRUCTOR: {
1518             # Do not run the constructor if there is a per-parse arg
1519 7952 100       10771 last RUN_CONSTRUCTOR if defined $per_parse_arg;
  7952         14963  
1520              
1521 7904         11054 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       16566 last RUN_CONSTRUCTOR if not defined $per_parse_constructor;
1526              
1527 7         18 my $constructor_arg0;
1528 7 100       35 if ( $recce->[Marpa::R2::Internal::Recognizer::RESOLVE_PACKAGE_SOURCE]
1529             eq 'legacy' )
1530             {
1531 4         12 $constructor_arg0 =
1532             $grammar->[Marpa::R2::Internal::Grammar::ACTION_OBJECT];
1533             } ## end if ( $recce->[...])
1534             else {
1535 3         8 $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         15 local $EVAL_ERROR = undef;
  7         18  
1543             local $SIG{__WARN__} = sub {
1544 0     0   0 push @warnings, [ $_[0], ( caller 0 ) ];
1545 7         86 };
1546              
1547 7         24 $eval_ok = eval {
1548 7         38 $semantics_arg0 = $per_parse_constructor->($constructor_arg0);
1549 7         45 1;
1550             };
1551 7         78 $fatal_error = $EVAL_ERROR;
1552             } ## end DO_EVAL:
1553              
1554 7 50 33     56 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     39646 $semantics_arg0 //= $per_parse_arg // {};
      66        
1567              
1568 7952         72290 my $value = Marpa::R2::Thin::V->new($tree);
1569 7952 100       18320 if ($slr) {
1570 5681         17694 $value->slr_set( $slr->thin() );
1571             }
1572             else {
1573 2271         3394 my $token_values =
1574             $recce->[Marpa::R2::Internal::Recognizer::TOKEN_VALUES];
1575 2271         5915 $value->valued_force();
1576             TOKEN_IX:
1577 2271         3808 for ( my $token_ix = 2; $token_ix <= $#{$token_values}; $token_ix++ )
  9196         17614  
1578             {
1579 6925         10234 my $token_value = $token_values->[$token_ix];
1580 6925 100       15220 $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         15008 local $Marpa::R2::Internal::Context::VALUATOR = $value;
1585 7952 100       24304 value_trace( $value, $trace_values ? 1 : 0 );
1586 7952         31735 $value->trace_values($trace_values);
1587 7952         79780 $value->stack_mode_set();
1588              
1589 7952         13788 my $null_values = $recce->[Marpa::R2::Internal::Recognizer::NULL_VALUES];
1590 7952         11613 my $nulling_closures =
1591             $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_SYMBOL_ID];
1592 7952         11440 my $rule_closures =
1593             $recce->[Marpa::R2::Internal::Recognizer::CLOSURE_BY_RULE_ID];
1594             REGISTRATION:
1595 7952         10911 for my $registration (
1596 7952         19379 @{ $recce->[Marpa::R2::Internal::Recognizer::REGISTRATIONS] } )
1597             {
1598 189766         230791 my ( $type, $id, @raw_ops ) = @{$registration};
  189766         344104  
1599 189766         253168 my @ops = ();
1600             PRINT_TRACES: {
1601 189766 50       227784 last PRINT_TRACES if $trace_values <= 2;
  189766         323904  
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         263787 OP: for my $raw_op (@raw_ops) {
1619 519496 100       803360 if ( ref $raw_op ) {
1620 28116         35296 push @ops, $value->constant_register( ${$raw_op} );
  28116         59360  
1621 28116         44414 next OP;
1622             }
1623 491380         666365 push @ops, $raw_op;
1624             } ## end OP: for my $raw_op (@raw_ops)
1625 189766 100       310226 if ( $type eq 'token' ) {
1626 94226         223087 $value->token_register( $id, @ops );
1627 94226         158450 next REGISTRATION;
1628             }
1629 95540 100       150761 if ( $type eq 'nulling' ) {
1630 7291         20529 $value->nulling_symbol_register( $id, @ops );
1631 7291         12926 next REGISTRATION;
1632             }
1633 88249 50       142444 if ( $type eq 'rule' ) {
1634 88249         233601 $value->rule_register( $id, @ops );
1635 88249         162529 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         11726 STEP: while (1) {
1644 130274         592820 my ( $value_type, @value_data ) = $value->stack_step();
1645              
1646 130274 100       269871 if ($trace_values) {
1647 100         137 EVENT: while (1) {
1648 114         228 my $event = $value->event();
1649 114 100       230 last EVENT if not defined $event;
1650 14         20 my ( $event_type, @event_data ) = @{$event};
  14         39  
1651 14 50       29 if ( $event_type eq 'MARPA_STEP_TOKEN' ) {
1652 14         26 my ( $token_id, $token_value_ix, $token_value ) = @event_data;
1653 14         39 trace_token_evaluation( $recce, $value, $token_id,
1654             $token_value );
1655 14         44 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       184 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       226996 last STEP if not defined $value_type;
1679 122332 100       212027 next STEP if $value_type eq 'trace';
1680              
1681 122302 100       199222 if ( $value_type eq 'MARPA_STEP_NULLING_SYMBOL' ) {
1682 1324         1924 my ($token_id) = @value_data;
1683 1324         2056 my $value_ref = $nulling_closures->[$token_id];
1684 1324         2578 my $result;
1685              
1686             my @warnings;
1687 1324         0 my $eval_ok;
1688              
1689             DO_EVAL: {
1690 1324         1685 local $SIG{__WARN__} = sub {
1691 0     0   0 push @warnings, [ $_[0], ( caller 0 ) ];
1692 1324         5848 };
1693              
1694 1324         2380 $eval_ok = eval {
1695 1324         2016 local $Marpa::R2::Context::rule =
1696             $null_values->[$token_id];
1697 1324         2798 $result = $value_ref->($semantics_arg0);
1698 1324         13472 1;
1699             };
1700              
1701             } ## end DO_EVAL:
1702              
1703 1324 50 33     4745 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         3433 $value->result_set($result);
1718 1324 50       2320 trace_token_evaluation( $recce, $value, $token_id, \$result )
1719             if $trace_values;
1720 1324         2440 next STEP;
1721             } ## end if ( $value_type eq 'MARPA_STEP_NULLING_SYMBOL' )
1722              
1723 120978 100       211395 if ( $value_type eq 'MARPA_STEP_RULE' ) {
1724 120929         181868 my ( $rule_id, $values ) = @value_data;
1725 120929         177620 my $closure = $rule_closures->[$rule_id];
1726              
1727 120929 50       195479 next STEP if not defined $closure;
1728 120929         150378 my $result;
1729              
1730 120929 50       228256 if ( ref $closure eq 'CODE' ) {
1731 120929         163297 my @warnings;
1732             my $eval_ok;
1733             DO_EVAL: {
1734 120929         154310 local $SIG{__WARN__} = sub {
1735 4     4   87 push @warnings, [ $_[0], ( caller 0 ) ];
1736 120929         515258 };
1737 120929         216565 local $Marpa::R2::Context::rule = $rule_id;
1738              
1739 120929 50       261574 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         172375 $eval_ok = eval {
1747 120929         150490 $result = $closure->( $semantics_arg0, @{$values} );
  120929         263027  
1748 120921         2303547 1;
1749             };
1750              
1751             } ## end DO_EVAL:
1752              
1753 120929 100 100     423164 if ( not $eval_ok or @warnings ) {
1754 10         20 my $fatal_error = $EVAL_ERROR;
1755 10         47 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         312567 $value->result_set($result);
1771              
1772 120919 100       221912 if ($trace_values) {
1773 18 50       26 say {$trace_file_handle}
  18         44  
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         86  
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         246638 next STEP;
1784              
1785             } ## end if ( $value_type eq 'MARPA_STEP_RULE' )
1786              
1787 49 50       90 if ( $value_type eq 'MARPA_STEP_TRACE' ) {
1788              
1789 49 100       94 if ( my $trace_output = trace_op( $grammar, $recce, $value ) ) {
1790 2 50       3 print {$trace_file_handle} $trace_output
  2         10  
1791             or Marpa::R2::exception('Could not print to trace file');
1792             }
1793              
1794 49         82 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         91604 return \( $value->absolute(0) );
1803              
1804             } ## end sub Marpa::R2::Recognizer::value
1805              
1806             sub do_high_rule_only {
1807 95     95   200 my ($recce) = @_;
1808 95         166 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
1809 95         392 $order->high_rank_only_set(1);
1810 95         393 $order->rank();
1811 95         181 return 1;
1812             } ## end sub do_high_rule_only
1813              
1814             sub do_rank_by_rule {
1815 8     8   30 my ($recce) = @_;
1816 8         23 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
1817              
1818             # Rank by rule is the default, but just in case
1819 8         60 $order->high_rank_only_set(0);
1820 8         55 $order->rank();
1821 8         19 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         3 my @data = ();
1830 1         2 my $id = 0;
1831 1         3 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1832 1         2 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         48 my $irl_id = $bocage->_marpa_b_or_node_irl($or_node_id);
1837 21 100       45 last OR_NODE if not defined $irl_id;
1838 20         38 my $position = $bocage->_marpa_b_or_node_position($or_node_id);
1839 20         36 my $or_origin = $bocage->_marpa_b_or_node_origin($or_node_id);
1840 20         36 my $origin_earleme = $recce_c->earleme($or_origin);
1841 20         37 my $or_set = $bocage->_marpa_b_or_node_set($or_node_id);
1842 20         37 my $current_earleme = $recce_c->earleme($or_set);
1843 20         50 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         39 my $symbol = $bocage->_marpa_b_and_node_symbol($and_node_id);
1850 23         31 my $cause_tag;
1851              
1852 23 100       41 if ( defined $symbol ) {
1853 7         13 $cause_tag = "S$symbol";
1854             }
1855 23         42 my $cause_id = $bocage->_marpa_b_and_node_cause($and_node_id);
1856 23 100       38 if ( defined $cause_id ) {
1857 16         34 $cause_tag = "OR#$cause_id=" .
1858             Marpa::R2::Recognizer::or_node_tag( $recce, $cause_id );
1859             }
1860 23         46 my $parent_tag =
1861             Marpa::R2::Recognizer::or_node_tag( $recce, $or_node_id );
1862 23         46 my $predecessor_id =
1863             $bocage->_marpa_b_and_node_predecessor($and_node_id);
1864 23         30 my $predecessor_tag = q{-};
1865 23 100       40 if ( defined $predecessor_id ) {
1866 10         28 $predecessor_tag =
1867             $predecessor_tag = "OR#$predecessor_id=" .
1868             Marpa::R2::Recognizer::or_node_tag( $recce, $predecessor_id );
1869             }
1870            
1871 23         85 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         83 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         6 my @sorted_data = map { $_->[-1] } sort { $a->[0] <=> $b->[0] } @data;
  23         43  
  22         32  
1878 1         46 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 144 my ( $recce, $and_node_id ) = @_;
1883 83         131 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1884 83         114 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1885 83         177 my $parent_or_node_id = $bocage->_marpa_b_and_node_parent($and_node_id);
1886 83         156 my $origin = $bocage->_marpa_b_or_node_origin($parent_or_node_id);
1887 83         176 my $origin_earleme = $recce_c->earleme($origin);
1888 83         154 my $current_earley_set =
1889             $bocage->_marpa_b_or_node_set($parent_or_node_id);
1890 83         146 my $current_earleme = $recce_c->earleme($current_earley_set);
1891 83         167 my $cause_id = $bocage->_marpa_b_and_node_cause($and_node_id);
1892 83         151 my $predecessor_id = $bocage->_marpa_b_and_node_predecessor($and_node_id);
1893              
1894 83         156 my $middle_earley_set = $bocage->_marpa_b_and_node_middle($and_node_id);
1895 83         140 my $middle_earleme = $recce_c->earleme($middle_earley_set);
1896              
1897 83         149 my $position = $bocage->_marpa_b_or_node_position($parent_or_node_id);
1898 83         218 my $irl_id = $bocage->_marpa_b_or_node_irl($parent_or_node_id);
1899              
1900             #<<< perltidy introduces trailing space on this
1901 83         206 my $tag =
1902             'R'
1903             . $irl_id . q{:}
1904             . $position . q{@}
1905             . $origin_earleme . q{-}
1906             . $current_earleme;
1907             #>>>
1908 83 100       155 if ( defined $cause_id ) {
1909 45         154 my $cause_irl_id = $bocage->_marpa_b_or_node_irl($cause_id);
1910 45         101 $tag .= 'C' . $cause_irl_id;
1911             }
1912             else {
1913 38         83 my $symbol = $bocage->_marpa_b_and_node_symbol($and_node_id);
1914 38         62 $tag .= 'S' . $symbol;
1915             }
1916 83         124 $tag .= q{@} . $middle_earleme;
1917 83         281 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     16 $verbose //= 0;
1923 2         5 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1924 2         5 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1925 2         5 my $text;
1926 2         6 my @data = ();
1927 2         5 AND_NODE: for ( my $id = 0;; $id++ ) {
1928 46         92 my $parent = $bocage->_marpa_b_and_node_parent($id);
1929 46         80 my $predecessor = $bocage->_marpa_b_and_node_predecessor($id);
1930 46         85 my $cause = $bocage->_marpa_b_and_node_cause($id);
1931 46         77 my $symbol = $bocage->_marpa_b_and_node_symbol($id);
1932 46 100       92 last AND_NODE if not defined $parent;
1933 44         79 my $origin = $bocage->_marpa_b_or_node_origin($parent);
1934 44         70 my $set = $bocage->_marpa_b_or_node_set($parent);
1935 44         96 my $irl_id = $bocage->_marpa_b_or_node_irl($parent);
1936 44         72 my $position = $bocage->_marpa_b_or_node_position($parent);
1937 44         76 my $origin_earleme = $recce_c->earleme($origin);
1938 44         80 my $current_earleme = $recce_c->earleme($set);
1939 44         67 my $middle_earley_set = $bocage->_marpa_b_and_node_middle($id);
1940 44         79 my $middle_earleme = $recce_c->earleme($middle_earley_set);
1941              
1942             #<<< perltidy introduces trailing space on this
1943 44         100 my $desc =
1944             "And-node #$id: R"
1945             . $irl_id . q{:}
1946             . $position . q{@}
1947             . $origin_earleme . q{-}
1948             . $current_earleme;
1949             #>>>
1950 44         55 my $cause_rule = -1;
1951 44 100       77 if ( defined $cause ) {
1952 26         44 my $cause_irl_id = $bocage->_marpa_b_or_node_irl($cause);
1953 26         57 $desc .= 'C' . $cause_irl_id;
1954             }
1955             else {
1956 18         39 $desc .= 'S' . $symbol;
1957             }
1958 44         67 $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         89 push @data, $desc;
1965             } ## end AND_NODE: for ( my $id = 0;; $id++ )
1966 2         30 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 157 my ( $recce, $or_node_id ) = @_;
1971 89         112 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1972 89         166 my $set = $bocage->_marpa_b_or_node_set($or_node_id);
1973 89         161 my $irl_id = $bocage->_marpa_b_or_node_irl($or_node_id);
1974 89         171 my $origin = $bocage->_marpa_b_or_node_origin($or_node_id);
1975 89         148 my $position = $bocage->_marpa_b_or_node_position($or_node_id);
1976 89         247 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 20 my ( $recce, $verbose ) = @_;
1981 2         6 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
1982 2         4 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
1983 2         4 my $text;
1984 2         14 my @data = ();
1985 2         4 my $id = 0;
1986 2         4 OR_NODE: for ( ;; ) {
1987 43         90 my $origin = $bocage->_marpa_b_or_node_origin($id);
1988 43         74 my $set = $bocage->_marpa_b_or_node_set($id);
1989 43         83 my $irl_id = $bocage->_marpa_b_or_node_irl($id);
1990 43         73 my $position = $bocage->_marpa_b_or_node_position($id);
1991 43         55 $id++;
1992 43 100       79 last OR_NODE if not defined $origin;
1993 41         75 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         126 my $desc =
1998             'R'
1999             . $irl_id . q{:}
2000             . $position . q{@}
2001             . $origin_earleme . q{-}
2002             . $current_earleme;
2003             #>>>
2004 41         142 push @data,
2005             [ $origin_earleme, $current_earleme, $irl_id, $position, $desc ];
2006             } ## end OR_NODE: for ( ;; )
2007 41         63 my @sorted_data = map { $_->[-1] } sort {
2008 2 50 100     19 $a->[0] <=> $b->[0]
  118   100     332  
2009             or $a->[1] <=> $b->[1]
2010             or $a->[2] <=> $b->[2]
2011             or $a->[3] <=> $b->[3]
2012             } @data;
2013 2         31 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 75 my ( $recce, $nook_id, $verbose ) = @_;
2094 44         78 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
2095 44         57 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
2096 44         57 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
2097              
2098 44         92 my $or_node_id = $tree->_marpa_t_nook_or_node($nook_id);
2099 44 100       83 return if not defined $or_node_id;
2100              
2101 40         69 my $text = "o$or_node_id";
2102 40   100     103 my $parent = $tree->_marpa_t_nook_parent($nook_id) // q{-};
2103             CHILD_TYPE: {
2104 40 100       58 if ( $tree->_marpa_t_nook_is_cause($nook_id) ) {
  40         86  
2105 24         34 $text .= "[c$parent]";
2106 24         37 last CHILD_TYPE;
2107             }
2108 16 100       43 if ( $tree->_marpa_t_nook_is_predecessor($nook_id) ) {
2109 12         25 $text .= "[p$parent]";
2110 12         16 last CHILD_TYPE;
2111             }
2112 4         6 $text .= '[-]';
2113             } ## end CHILD_TYPE:
2114 40         72 my $or_node_tag =
2115             Marpa::R2::Recognizer::or_node_tag( $recce, $or_node_id );
2116 40         72 $text .= " $or_node_tag";
2117              
2118 40         52 $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         56 $text .= "\n";
2126              
2127             DESCRIBE_CHOICES: {
2128 40         49 my $this_choice = $tree->_marpa_t_nook_choice($nook_id);
  40         69  
2129 40         60 CHOICE: for ( my $choice_ix = 0;; $choice_ix++ ) {
2130 89         169 my $and_node_id =
2131             $order->_marpa_o_and_node_order_get( $or_node_id,
2132             $choice_ix );
2133 89 100       205 last CHOICE if not defined $and_node_id;
2134 49         86 $text .= " o$or_node_id" . '[' . $choice_ix . ']';
2135 49 100 66     158 if ( defined $this_choice and $this_choice == $choice_ix ) {
2136 40         52 $text .= q{*};
2137             }
2138 49         84 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         96 $text .= "\n";
2142             } ## end CHOICE: for ( my $choice_ix = 0;; $choice_ix++ )
2143             } ## end DESCRIBE_CHOICES:
2144 40         79 return $text;
2145             } ## end sub Marpa::R2::Recognizer::show_nook
2146              
2147             sub Marpa::R2::Recognizer::show_tree {
2148 4     4 0 42 my ( $recce, $verbose ) = @_;
2149 4         8 my $text = q{};
2150 4         7 NOOK: for ( my $nook_id = 0; 1; $nook_id++ ) {
2151 44         84 my $nook_text = $recce->show_nook( $nook_id, $verbose );
2152 44 100       82 last NOOK if not defined $nook_text;
2153 40         86 $text .= "$nook_id: $nook_text";
2154             }
2155 4         23 return $text;
2156             } ## end sub Marpa::R2::Recognizer::show_tree
2157              
2158             sub trace_token_evaluation {
2159 14     14   28 my ( $recce, $value, $token_id, $token_value ) = @_;
2160 14         23 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
2161 14         22 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
2162 14         21 my $grammar = $recce->[Marpa::R2::Internal::Recognizer::GRAMMAR];
2163              
2164 14         49 my $nook_ix = $value->_marpa_v_nook();
2165 14 50       33 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         42 my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix);
2171 14         30 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         21 my $token_name;
2175 14 50       28 if ( defined $token_id ) {
2176 14         44 $token_name = $grammar->symbol_name($token_id);
2177             }
2178              
2179 14 50       20 print {$Marpa::R2::Internal::TRACE_FH}
  14 50       41  
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   40 my ( $grammar, $recce, $value, $args, $rule_id ) = @_;
2193 18         31 my $recce_c = $recce->[Marpa::R2::Internal::Recognizer::C];
2194 18         26 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
2195 18         29 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
2196 18         24 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
2197              
2198 18         31 my $argc = scalar @{$args};
  18         36  
2199 18         43 my $nook_ix = $value->_marpa_v_nook();
2200 18         47 my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix);
2201 18         39 my $choice = $tree->_marpa_t_nook_choice($nook_ix);
2202 18         40 my $and_node_id =
2203             $order->_marpa_o_and_node_order_get( $or_node_id, $choice );
2204              
2205 18         40 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   85 my ( $grammar, $recce, $value ) = @_;
2215              
2216 49         71 my $trace_output = q{};
2217 49   50     99 my $trace_values =
2218             $recce->[Marpa::R2::Internal::Recognizer::TRACE_VALUES] // 0;
2219              
2220 49 100       110 return $trace_output if not $trace_values >= 2;
2221              
2222 32         50 my $grammar_c = $grammar->[Marpa::R2::Internal::Grammar::C];
2223 32         46 my $bocage = $recce->[Marpa::R2::Internal::Recognizer::B_C];
2224 32         44 my $order = $recce->[Marpa::R2::Internal::Recognizer::O_C];
2225 32         49 my $tree = $recce->[Marpa::R2::Internal::Recognizer::T_C];
2226              
2227 32         79 my $nook_ix = $value->_marpa_v_nook();
2228 32         66 my $or_node_id = $tree->_marpa_t_nook_or_node($nook_ix);
2229 32         65 my $choice = $tree->_marpa_t_nook_choice($nook_ix);
2230 32         69 my $and_node_id =
2231             $order->_marpa_o_and_node_order_get( $or_node_id, $choice );
2232 32         73 my $trace_irl_id = $bocage->_marpa_b_or_node_irl($or_node_id);
2233 32         81 my $virtual_rhs = $grammar_c->_marpa_g_irl_is_virtual_rhs($trace_irl_id);
2234 32         63 my $virtual_lhs = $grammar_c->_marpa_g_irl_is_virtual_lhs($trace_irl_id);
2235              
2236 32 100       140 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     120 return $trace_output if not $virtual_rhs and not $virtual_lhs;
2241              
2242 2 50 33     15 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     12 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     25 if ( not $virtual_rhs and $virtual_lhs ) {
2273              
2274 2         9 $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         11 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   15407 my ( $value, $trace_flag ) = @_;
2291 7952         21234 return $value->_marpa_v_trace($trace_flag);
2292             }
2293              
2294             1;
2295              
2296             # vim: expandtab shiftwidth=4: