1# Copyright 2012 Jeffrey Kegler 2# This file is part of Marpa::XS. Marpa::XS 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::XS 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::XS. If not, see 14# http://www.gnu.org/licenses/. 15 16package Marpa::XS::Value; 17 18use 5.010; 19use warnings; 20use strict; 21use integer; 22 23use vars qw($VERSION $STRING_VERSION); 24$VERSION = '1.008000'; 25$STRING_VERSION = $VERSION; 26## no critic (BuiltinFunctions::ProhibitStringyEval) 27$VERSION = eval $VERSION; 28## use critic 29 30package Marpa::XS::Internal::Value; 31 32use English qw( -no_match_vars ); 33 34use constant SKIP => -1; 35 36sub Marpa::XS::Recognizer::parse_count { 37 my ($recce) = @_; 38 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 39 return $recce_c->parse_count(); 40} 41 42sub Marpa::XS::Recognizer::show_bocage { 43 my ($recce) = @_; 44 my $text; 45 my @data = (); 46 my $id = 0; 47 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 48 my $grammar = $recce->[Marpa::XS::Internal::Recognizer::GRAMMAR]; 49 my $symbol_hash = $grammar->[Marpa::XS::Internal::Grammar::SYMBOL_HASH]; 50 OR_NODE: for ( my $or_node_id = 0;; $or_node_id++ ) { 51 my $rule = $recce_c->or_node_rule($or_node_id); 52 last OR_NODE if not defined $rule; 53 my $position = $recce_c->or_node_position($or_node_id); 54 my $or_origin = $recce_c->or_node_origin($or_node_id); 55 my $origin_earleme = $recce_c->earleme($or_origin); 56 my $or_set = $recce_c->or_node_set($or_node_id); 57 my $current_earleme = $recce_c->earleme($or_set); 58 my @and_node_ids = 59 ( $recce_c->or_node_first_and($or_node_id) 60 .. $recce_c->or_node_last_and($or_node_id) ); 61 AND_NODE: 62 63 for my $and_node_id (@and_node_ids) { 64 my $symbol = $recce_c->and_node_symbol($and_node_id); 65 my $cause_tag; 66 67 if ( defined $symbol ) { 68 $cause_tag = "S$symbol"; 69 } 70 my $cause_rule = -1; 71 my $cause_id = $recce_c->and_node_cause($and_node_id); 72 if ( defined $cause_id ) { 73 $cause_rule = $recce_c->or_node_rule($cause_id); 74 $cause_tag = 75 Marpa::XS::Recognizer::or_node_tag( $recce, $cause_id ); 76 } 77 my $parent_tag = 78 Marpa::XS::Recognizer::or_node_tag( $recce, $or_node_id ); 79 my $predecessor_id = $recce_c->and_node_predecessor($and_node_id); 80 my $predecessor_tag = q{-}; 81 if ( defined $predecessor_id ) { 82 $predecessor_tag = Marpa::XS::Recognizer::or_node_tag( $recce, 83 $predecessor_id ); 84 } 85 my $tag = join q{ }, $parent_tag, $predecessor_tag, $cause_tag; 86 my $middle_earleme = $origin_earleme; 87 if ( defined $predecessor_id ) { 88 my $predecessor_set = $recce_c->or_node_set($predecessor_id); 89 $middle_earleme = $recce_c->earleme($predecessor_set); 90 } 91 92 push @data, 93 [ 94 $origin_earleme, $current_earleme, $rule, 95 $position, $middle_earleme, $cause_rule, 96 ( $symbol // -1 ), $tag 97 ]; 98 } ## end for my $and_node_id (@and_node_ids) 99 } ## end for ( my $or_node_id = 0;; $or_node_id++ ) 100 my @sorted_data = map { $_->[-1] } sort { 101 $a->[0] <=> $b->[0] 102 or $a->[1] <=> $b->[1] 103 or $a->[2] <=> $b->[2] 104 or $a->[3] <=> $b->[3] 105 or $a->[4] <=> $b->[4] 106 or $a->[5] <=> $b->[5] 107 or $a->[6] <=> $b->[6] 108 } @data; 109 return ( join "\n", @sorted_data ) . "\n"; 110} ## end sub Marpa::XS::Recognizer::show_bocage 111 112sub Marpa::XS::Recognizer::and_node_tag { 113 my ( $recce, $and_node_id ) = @_; 114 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 115 my $parent_or_node_id = $recce_c->and_node_parent($and_node_id); 116 my $origin = $recce_c->or_node_origin($parent_or_node_id); 117 my $origin_earleme = $recce_c->earleme($origin); 118 my $current_earley_set = $recce_c->or_node_set($parent_or_node_id); 119 my $current_earleme = $recce_c->earleme($current_earley_set); 120 my $cause_id = $recce_c->and_node_cause($and_node_id); 121 my $predecessor_id = $recce_c->and_node_predecessor($and_node_id); 122 my $middle_earleme = $origin_earleme; 123 if ( defined $predecessor_id ) { 124 my $middle_set = $recce_c->or_node_set($predecessor_id); 125 $middle_earleme = $recce_c->earleme($middle_set); 126 } 127 my $position = $recce_c->or_node_position($parent_or_node_id); 128 my $rule = $recce_c->or_node_rule($parent_or_node_id); 129 130#<<< perltidy introduces trailing space on this 131 my $tag = 132 'R' 133 . $rule . q{:} 134 . $position . q{@} 135 . $origin_earleme . q{-} 136 . $current_earleme; 137#>>> 138 if ( defined $cause_id ) { 139 my $cause_rule = $recce_c->or_node_rule($cause_id); 140 $tag .= 'C' . $cause_rule; 141 } 142 else { 143 my $symbol = $recce_c->and_node_symbol($and_node_id); 144 $tag .= 'S' . $symbol; 145 } 146 $tag .= q{@} . $middle_earleme; 147 return $tag; 148} ## end sub Marpa::XS::Recognizer::and_node_tag 149 150sub Marpa::XS::Recognizer::show_and_nodes { 151 my ($recce) = @_; 152 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 153 my $text; 154 my @data = (); 155 AND_NODE: for ( my $id = 0;; $id++ ) { 156 my $parent = $recce_c->and_node_parent($id); 157 my $predecessor = $recce_c->and_node_predecessor($id); 158 my $cause = $recce_c->and_node_cause($id); 159 my $symbol = $recce_c->and_node_symbol($id); 160 last AND_NODE if not defined $parent; 161 my $origin = $recce_c->or_node_origin($parent); 162 my $set = $recce_c->or_node_set($parent); 163 my $rule = $recce_c->or_node_rule($parent); 164 my $position = $recce_c->or_node_position($parent); 165 my $origin_earleme = $recce_c->earleme($origin); 166 my $current_earleme = $recce_c->earleme($set); 167 my $middle_earleme = $origin_earleme; 168 169 if ( defined $predecessor ) { 170 my $predecessor_set = $recce_c->or_node_set($predecessor); 171 $middle_earleme = $recce_c->earleme($predecessor_set); 172 } 173 174#<<< perltidy introduces trailing space on this 175 my $desc = 176 'R' 177 . $rule . q{:} 178 . $position . q{@} 179 . $origin_earleme . q{-} 180 . $current_earleme; 181#>>> 182 my $cause_rule = -1; 183 if ( defined $cause ) { 184 $cause_rule = $recce_c->or_node_rule($cause); 185 $desc .= 'C' . $cause_rule; 186 } 187 else { 188 $desc .= 'S' . $symbol; 189 } 190 $desc .= q{@} . $middle_earleme; 191 push @data, 192 [ 193 $origin_earleme, $current_earleme, $rule, 194 $position, $middle_earleme, $cause_rule, 195 ( $symbol // -1 ), $desc 196 ]; 197 } ## end for ( my $id = 0;; $id++ ) 198 my @sorted_data = map { $_->[-1] } sort { 199 $a->[0] <=> $b->[0] 200 or $a->[1] <=> $b->[1] 201 or $a->[2] <=> $b->[2] 202 or $a->[3] <=> $b->[3] 203 or $a->[4] <=> $b->[4] 204 or $a->[5] <=> $b->[5] 205 or $a->[6] <=> $b->[6] 206 } @data; 207 return ( join "\n", @sorted_data ) . "\n"; 208} ## end sub Marpa::XS::Recognizer::show_and_nodes 209 210sub Marpa::XS::Recognizer::or_node_tag { 211 my ( $recce, $or_node_id ) = @_; 212 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 213 my $set = $recce_c->or_node_set($or_node_id); 214 my $rule = $recce_c->or_node_rule($or_node_id); 215 my $origin = $recce_c->or_node_origin($or_node_id); 216 my $position = $recce_c->or_node_position($or_node_id); 217 return 'R' . $rule . q{:} . $position . q{@} . $origin . q{-} . $set; 218} ## end sub Marpa::XS::Recognizer::or_node_tag 219 220sub Marpa::XS::Recognizer::show_or_nodes { 221 my ( $recce, $verbose ) = @_; 222 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 223 my $text; 224 my @data = (); 225 my $id = 0; 226 OR_NODE: for ( ;; ) { 227 my $origin = $recce_c->or_node_origin($id); 228 my $set = $recce_c->or_node_set($id); 229 my $rule = $recce_c->or_node_rule($id); 230 my $position = $recce_c->or_node_position($id); 231 $id++; 232 last OR_NODE if not defined $origin; 233 my $origin_earleme = $recce_c->earleme($origin); 234 my $current_earleme = $recce_c->earleme($set); 235 236#<<< perltidy introduces trailing space on this 237 my $desc = 238 'R' 239 . $rule . q{:} 240 . $position . q{@} 241 . $origin_earleme . q{-} 242 . $current_earleme; 243#>>> 244 push @data, 245 [ $origin_earleme, $current_earleme, $rule, $position, $desc ]; 246 } ## end for ( ;; ) 247 my @sorted_data = map { $_->[-1] } sort { 248 $a->[0] <=> $b->[0] 249 or $a->[1] <=> $b->[1] 250 or $a->[2] <=> $b->[2] 251 or $a->[3] <=> $b->[3] 252 } @data; 253 return ( join "\n", @sorted_data ) . "\n"; 254} ## end sub Marpa::XS::Recognizer::show_or_nodes 255 256sub Marpa::XS::show_rank_ref { 257 my ($rank_ref) = @_; 258 return 'undef' if not defined $rank_ref; 259 return 'SKIP' if $rank_ref == Marpa::XS::Internal::Value::SKIP; 260 return ${$rank_ref}; 261} ## end sub Marpa::XS::show_rank_ref 262 263sub Marpa::XS::Recognizer::show_fork { 264 my ( $recce, $fork_id, $verbose ) = @_; 265 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 266 267 my $or_node_id = $recce_c->fork_or_node($fork_id); 268 return if not defined $or_node_id; 269 270 my $text = "o$or_node_id"; 271 my $parent = $recce_c->fork_parent($fork_id) // q{-}; 272 CHILD_TYPE: { 273 if ( $recce_c->fork_is_cause($fork_id) ) { 274 $text .= "[c$parent]"; 275 last CHILD_TYPE; 276 } 277 if ( $recce_c->fork_is_predecessor($fork_id) ) { 278 $text .= "[p$parent]"; 279 last CHILD_TYPE; 280 } 281 $text .= '[-]'; 282 } ## end CHILD_TYPE: 283 my $or_node_tag = 284 Marpa::XS::Recognizer::or_node_tag( $recce, $or_node_id ); 285 $text .= " $or_node_tag"; 286 287 $text .= ' p'; 288 $text .= $recce_c->fork_predecessor_is_ready($fork_id) ? q{=ok} : q{-}; 289 $text .= ' c'; 290 $text .= $recce_c->fork_cause_is_ready($fork_id) ? q{=ok} : q{-}; 291 $text .= "\n"; 292 293 DESCRIBE_CHOICES: { 294 my $this_choice = $recce_c->fork_choice($fork_id); 295 CHOICE: for ( my $choice_ix = 0;; $choice_ix++ ) { 296 my $and_node_id = 297 $recce_c->and_node_order_get( $or_node_id, $choice_ix ); 298 last CHOICE if not defined $and_node_id; 299 $text .= " o$or_node_id" . '[' . $choice_ix . ']'; 300 if ( defined $this_choice and $this_choice == $choice_ix ) { 301 $text .= q{*}; 302 } 303 my $and_node_tag = 304 Marpa::XS::Recognizer::and_node_tag( $recce, $and_node_id ); 305 $text .= " ::= a$and_node_id $and_node_tag"; 306 $text .= "\n"; 307 } ## end for ( my $choice_ix = 0;; $choice_ix++ ) 308 } ## end DESCRIBE_CHOICES: 309 return $text; 310} ## end sub Marpa::XS::Recognizer::show_fork 311 312sub Marpa::XS::Recognizer::show_tree { 313 my ( $recce, $verbose ) = @_; 314 my $text = q{}; 315 FORK: for ( my $fork_id = 0; 1; $fork_id++ ) { 316 my $fork_text = $recce->show_fork( $fork_id, $verbose ); 317 last FORK if not defined $fork_text; 318 $text .= "$fork_id: $fork_text"; 319 } 320 return $text; 321} ## end sub Marpa::XS::Recognizer::show_tree 322 323package Marpa::XS::Internal::Recognizer; 324our $DEFAULT_ACTION_VALUE = \undef; 325 326package Marpa::XS::Internal::Value; 327 328sub Marpa::XS::Internal::Recognizer::set_null_values { 329 my ($recce) = @_; 330 my $grammar = $recce->[Marpa::XS::Internal::Recognizer::GRAMMAR]; 331 my $grammar_c = $grammar->[Marpa::XS::Internal::Grammar::C]; 332 my $trace_values = 333 $recce->[Marpa::XS::Internal::Recognizer::TRACE_VALUES]; 334 335 my $rules = $grammar->[Marpa::XS::Internal::Grammar::RULES]; 336 my $symbols = $grammar->[Marpa::XS::Internal::Grammar::SYMBOLS]; 337 my $default_null_value = 338 $grammar->[Marpa::XS::Internal::Grammar::DEFAULT_NULL_VALUE]; 339 340 my $null_values; 341 $#{$null_values} = $#{$symbols}; 342 343 SYMBOL: for my $symbol ( @{$symbols} ) { 344 345 my $symbol_id = $symbol->[Marpa::XS::Internal::Symbol::ID]; 346 347 next SYMBOL if not $grammar_c->symbol_is_nulling($symbol_id); 348 349 my $null_value = undef; 350 if ( $symbol->[Marpa::XS::Internal::Symbol::NULL_VALUE] ) { 351 $null_value = 352 ${ $symbol->[Marpa::XS::Internal::Symbol::NULL_VALUE] }; 353 } 354 else { 355 $null_value = $default_null_value; 356 } 357 next SYMBOL if not defined $null_value; 358 359 $null_values->[$symbol_id] = $null_value; 360 361 if ($trace_values) { 362 print {$Marpa::XS::Internal::TRACE_FH} 363 'Setting null value for symbol ', 364 $symbol->[Marpa::XS::Internal::Symbol::NAME], 365 ' to ', Data::Dumper->new( [ \$null_value ] )->Terse(1)->Dump 366 or Marpa::XS::exception('Could not print to trace file'); 367 } ## end if ($trace_values) 368 369 } ## end for my $symbol ( @{$symbols} ) 370 371 return $null_values; 372 373} # set_null_values 374 375# Given the grammar and an action name, resolve it to a closure, 376# or return undef 377sub Marpa::XS::Internal::Recognizer::resolve_semantics { 378 my ( $recce, $closure_name ) = @_; 379 my $grammar = $recce->[Marpa::XS::Internal::Recognizer::GRAMMAR]; 380 my $closures = $recce->[Marpa::XS::Internal::Recognizer::CLOSURES]; 381 my $trace_actions = 382 $recce->[Marpa::XS::Internal::Recognizer::TRACE_ACTIONS]; 383 384 Marpa::XS::exception(q{Trying to resolve 'undef' as closure name}) 385 if not defined $closure_name; 386 387 if ( my $closure = $closures->{$closure_name} ) { 388 if ($trace_actions) { 389 print {$Marpa::XS::Internal::TRACE_FH} 390 qq{Resolved "$closure_name" to explicit closure\n} 391 or Marpa::XS::exception('Could not print to trace file'); 392 } 393 394 return $closure; 395 } ## end if ( my $closure = $closures->{$closure_name} ) 396 397 my $fully_qualified_name; 398 DETERMINE_FULLY_QUALIFIED_NAME: { 399 if ( $closure_name =~ /([:][:])|[']/xms ) { 400 $fully_qualified_name = $closure_name; 401 last DETERMINE_FULLY_QUALIFIED_NAME; 402 } 403 if (defined( 404 my $actions_package = 405 $grammar->[Marpa::XS::Internal::Grammar::ACTIONS] 406 ) 407 ) 408 { 409 $fully_qualified_name = $actions_package . q{::} . $closure_name; 410 last DETERMINE_FULLY_QUALIFIED_NAME; 411 } ## end if ( defined( my $actions_package = $grammar->[...])) 412 413 if (defined( 414 my $action_object_class = 415 $grammar->[Marpa::XS::Internal::Grammar::ACTION_OBJECT] 416 ) 417 ) 418 { 419 $fully_qualified_name = 420 $action_object_class . q{::} . $closure_name; 421 } ## end if ( defined( my $action_object_class = $grammar->[...])) 422 } ## end DETERMINE_FULLY_QUALIFIED_NAME: 423 424 return if not defined $fully_qualified_name; 425 426 no strict 'refs'; 427 my $closure = *{$fully_qualified_name}{'CODE'}; 428 use strict 'refs'; 429 430 if ($trace_actions) { 431 print {$Marpa::XS::Internal::TRACE_FH} 432 ( $closure ? 'Successful' : 'Failed' ) 433 . qq{ resolution of "$closure_name" }, 434 'to ', $fully_qualified_name, "\n" 435 or Marpa::XS::exception('Could not print to trace file'); 436 } ## end if ($trace_actions) 437 438 return $closure; 439 440} ## end sub Marpa::XS::Internal::Recognizer::resolve_semantics 441 442sub Marpa::XS::Internal::Recognizer::set_actions { 443 my ($recce) = @_; 444 my $grammar = $recce->[Marpa::XS::Internal::Recognizer::GRAMMAR]; 445 my $grammar_c = $grammar->[Marpa::XS::Internal::Grammar::C]; 446 my $rules = $grammar->[Marpa::XS::Internal::Grammar::RULES]; 447 my $symbols = $grammar->[Marpa::XS::Internal::Grammar::SYMBOLS]; 448 my $default_action = 449 $grammar->[Marpa::XS::Internal::Grammar::DEFAULT_ACTION]; 450 451 my $rule_closures = []; 452 my $rule_constants = []; 453 454 my $default_action_closure; 455 if ( defined $default_action ) { 456 $default_action_closure = 457 Marpa::XS::Internal::Recognizer::resolve_semantics( $recce, 458 $default_action ); 459 Marpa::XS::exception( 460 "Could not resolve default action named '$default_action'") 461 if not $default_action_closure; 462 } ## end if ( defined $default_action ) 463 464 RULE: for my $rule ( @{$rules} ) { 465 466 my $rule_id = $rule->[Marpa::XS::Internal::Rule::ID]; 467 468 if ( my $action = $rule->[Marpa::XS::Internal::Rule::ACTION] ) { 469 my $closure = 470 Marpa::XS::Internal::Recognizer::resolve_semantics( $recce, 471 $action ); 472 473 Marpa::XS::exception(qq{Could not resolve action name: "$action"}) 474 if not defined $closure; 475 $rule_closures->[$rule_id] = $closure; 476 next RULE; 477 } ## end if ( my $action = $rule->[Marpa::XS::Internal::Rule::ACTION...]) 478 479 # Try to resolve the LHS as a closure name, 480 # if it is not internal. 481 # If we can't resolve 482 # the LHS as a closure name, it's not 483 # a fatal error. 484 FIND_CLOSURE_BY_LHS: { 485 my $lhs_id = $grammar_c->rule_lhs($rule_id); 486 my $action = 487 $symbols->[$lhs_id]->[Marpa::XS::Internal::Symbol::NAME]; 488 last FIND_CLOSURE_BY_LHS if substr( $action, -1 ) eq ']'; 489 my $closure = 490 Marpa::XS::Internal::Recognizer::resolve_semantics( $recce, 491 $action ); 492 last FIND_CLOSURE_BY_LHS if not defined $closure; 493 $rule_closures->[$rule_id] = $closure; 494 next RULE; 495 } ## end FIND_CLOSURE_BY_LHS: 496 497 if ( defined $default_action_closure ) { 498 $rule_closures->[$rule_id] = $default_action_closure; 499 next RULE; 500 } 501 502 # If there is no default action specified, the fallback 503 # is to return an undef 504 $rule_constants->[$rule_id] = 505 $Marpa::XS::Internal::Recognizer::DEFAULT_ACTION_VALUE; 506 507 } ## end for my $rule ( @{$rules} ) 508 509 $recce->[Marpa::XS::Internal::Recognizer::RULE_CLOSURES] = $rule_closures; 510 $recce->[Marpa::XS::Internal::Recognizer::RULE_CONSTANTS] = 511 $rule_constants; 512 513 return 1; 514} # set_actions 515 516sub do_high_rule_only { 517 my ($recce) = @_; 518 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 519 my $grammar = $recce->[Marpa::XS::Internal::Recognizer::GRAMMAR]; 520 my $grammar_c = $grammar->[Marpa::XS::Internal::Grammar::C]; 521 my $symbols = $grammar->[Marpa::XS::Internal::Grammar::SYMBOLS]; 522 my $rules = $grammar->[Marpa::XS::Internal::Grammar::RULES]; 523 524 my @or_nodes = 525 ( $recce->[Marpa::XS::Internal::Recognizer::TOP_OR_NODE_ID] ); 526 527 # Set up ranks by symbol 528 my @rank_by_symbol = (); 529 SYMBOL: for my $symbol ( @{$symbols} ) { 530 my $rank = $symbol->[Marpa::XS::Internal::Symbol::TERMINAL_RANK]; 531 $rank_by_symbol[ $symbol->[Marpa::XS::Internal::Symbol::ID] ] = $rank; 532 } # end for my $symbol ( @{$symbols} ) 533 534 # Set up ranks by rule 535 my @rank_by_rule = (); 536 SYMBOL: for my $rule ( @{$rules} ) { 537 my $rank = $rule->[Marpa::XS::Internal::Rule::RANK]; 538 $rank_by_rule[ $rule->[Marpa::XS::Internal::Rule::ID] ] = $rank; 539 } # end for my $rule ( @{$rules} ) 540 541 OR_NODE: for ( my $or_node = 0;; $or_node++ ) { 542 my $first_and_node = $recce_c->or_node_first_and($or_node); 543 last OR_NODE if not defined $first_and_node; 544 my $last_and_node = $recce_c->or_node_last_and($or_node); 545 my @ranking_data = (); 546 my @and_nodes = $first_and_node .. $last_and_node; 547 AND_NODE: 548 549 for my $and_node (@and_nodes) { 550 my $token = $recce_c->and_node_symbol($and_node); 551 if ( defined $token ) { 552 push @ranking_data, 553 [ $and_node, $rank_by_symbol[$token], 99 ]; 554 next AND_NODE; 555 } 556 my $cause = $recce_c->and_node_cause($and_node); 557 my $rule_id = $recce_c->or_node_rule($cause); 558 my $rule = $rules->[$rule_id]; 559 push @ranking_data, 560 [ 561 $and_node, $rank_by_rule[$rule_id], 562 $rule->[Marpa::XS::Internal::Rule::CHAF_RANK] 563 ]; 564 } ## end for my $and_node (@and_nodes) 565 566## no critic(BuiltinFunctions::ProhibitReverseSortBlock) 567 my @sorted_and_data = 568 sort { $b->[1] <=> $a->[1] or $b->[2] <=> $a->[2] } @ranking_data; 569## use critic 570 571 my ( $first_selected_and_node, $high_rule_rank, $high_chaf_rank ) = 572 @{ $sorted_and_data[0] }; 573 my @selected_and_nodes = ($first_selected_and_node); 574 AND_DATUM: 575 for my $and_datum ( @sorted_and_data[ 1 .. $#sorted_and_data ] ) { 576 my ( $and_node, $rule_rank, $chaf_rank ) = @{$and_datum}; 577 last AND_DATUM if $rule_rank < $high_rule_rank; 578 last AND_DATUM if $chaf_rank < $high_chaf_rank; 579 push @selected_and_nodes, $and_node; 580 } ## end for my $and_datum ( @sorted_and_data[ 1 .. $#sorted_and_data...]) 581 $recce_c->and_node_order_set( $or_node, \@selected_and_nodes ); 582 push @or_nodes, grep {defined} map { 583 ( $recce_c->and_node_predecessor($_), 584 $recce_c->and_node_cause($_) 585 ) 586 } @selected_and_nodes; 587 } ## end for ( my $or_node = 0;; $or_node++ ) 588 return 1; 589} ## end sub do_high_rule_only 590 591sub do_rank_by_rule { 592 my ($recce) = @_; 593 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 594 my $grammar = $recce->[Marpa::XS::Internal::Recognizer::GRAMMAR]; 595 my $grammar_c = $grammar->[Marpa::XS::Internal::Grammar::C]; 596 my $symbols = $grammar->[Marpa::XS::Internal::Grammar::SYMBOLS]; 597 my $rules = $grammar->[Marpa::XS::Internal::Grammar::RULES]; 598 599 my @or_nodes = 600 ( $recce->[Marpa::XS::Internal::Recognizer::TOP_OR_NODE_ID] ); 601 602 # Set up ranks by symbol 603 my @rank_by_symbol = (); 604 SYMBOL: for my $symbol ( @{$symbols} ) { 605 my $rank = $symbol->[Marpa::XS::Internal::Symbol::TERMINAL_RANK]; 606 $rank_by_symbol[ $symbol->[Marpa::XS::Internal::Symbol::ID] ] = $rank; 607 } # end for my $symbol ( @{$symbols} ) 608 609 # Set up ranks by rule 610 my @rank_by_rule = (); 611 SYMBOL: for my $rule ( @{$rules} ) { 612 my $rank = $rule->[Marpa::XS::Internal::Rule::RANK]; 613 $rank_by_rule[ $rule->[Marpa::XS::Internal::Rule::ID] ] = $rank; 614 } # end for my $rule ( @{$rules} ) 615 616 my $seen = q{}; 617 OR_NODE: while ( my $or_node = pop @or_nodes ) { 618 last OR_NODE if not defined $or_node; 619 next OR_NODE if vec $seen, $or_node, 1; 620 vec( $seen, $or_node, 1 ) = 1; 621 my $first_and_node = $recce_c->or_node_first_and($or_node); 622 my $last_and_node = $recce_c->or_node_last_and($or_node); 623 my @ranking_data = (); 624 my @and_nodes = $first_and_node .. $last_and_node; 625 AND_NODE: 626 627 for my $and_node (@and_nodes) { 628 my $token = $recce_c->and_node_symbol($and_node); 629 if ( defined $token ) { 630 push @ranking_data, 631 [ $and_node, $rank_by_symbol[$token], 99 ]; 632 next AND_NODE; 633 } 634 my $cause = $recce_c->and_node_cause($and_node); 635 my $rule_id = $recce_c->or_node_rule($cause); 636 my $rule = $rules->[$rule_id]; 637 push @ranking_data, 638 [ 639 $and_node, $rank_by_rule[$rule_id], 640 $rule->[Marpa::XS::Internal::Rule::CHAF_RANK] 641 ]; 642 } ## end for my $and_node (@and_nodes) 643 644## no critic(BuiltinFunctions::ProhibitReverseSortBlock) 645 my @ranked_and_nodes = 646 map { $_->[0] } 647 sort { $b->[1] <=> $a->[1] or $b->[2] <=> $a->[2] } @ranking_data; 648## use critic 649 650 $recce_c->and_node_order_set( $or_node, \@ranked_and_nodes ); 651 push @or_nodes, grep {defined} map { 652 ( $recce_c->and_node_predecessor($_), 653 $recce_c->and_node_cause($_) 654 ) 655 } @ranked_and_nodes; 656 } ## end while ( my $or_node = pop @or_nodes ) 657 return 1; 658} ## end sub do_rank_by_rule 659 660# Does not modify stack 661sub Marpa::XS::Internal::Recognizer::evaluate { 662 my ($recce) = @_; 663 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 664 my $null_values = $recce->[Marpa::XS::Internal::Recognizer::NULL_VALUES]; 665 my $grammar = $recce->[Marpa::XS::Internal::Recognizer::GRAMMAR]; 666 my $token_values = 667 $recce->[Marpa::XS::Internal::Recognizer::TOKEN_VALUES]; 668 my $grammar_c = $grammar->[Marpa::XS::Internal::Grammar::C]; 669 my $symbols = $grammar->[Marpa::XS::Internal::Grammar::SYMBOLS]; 670 my $trace_values = $recce->[Marpa::XS::Internal::Recognizer::TRACE_VALUES] 671 // 0; 672 673 my $rule_constants = 674 $recce->[Marpa::XS::Internal::Recognizer::RULE_CONSTANTS]; 675 my $rule_closures = 676 $recce->[Marpa::XS::Internal::Recognizer::RULE_CLOSURES]; 677 678 my $action_object_class = 679 $grammar->[Marpa::XS::Internal::Grammar::ACTION_OBJECT]; 680 681 my $action_object_constructor; 682 if ( defined $action_object_class ) { 683 my $constructor_name = $action_object_class . q{::new}; 684 my $closure = 685 Marpa::XS::Internal::Recognizer::resolve_semantics( $recce, 686 $constructor_name ); 687 Marpa::XS::exception( 688 qq{Could not find constructor "$constructor_name"}) 689 if not defined $closure; 690 $action_object_constructor = $closure; 691 } ## end if ( defined $action_object_class ) 692 693 my $action_object; 694 if ($action_object_constructor) { 695 my @warnings; 696 my $eval_ok; 697 my $fatal_error; 698 DO_EVAL: { 699 local $EVAL_ERROR = undef; 700 local $SIG{__WARN__} = sub { 701 push @warnings, [ $_[0], ( caller 0 ) ]; 702 }; 703 704 $eval_ok = eval { 705 $action_object = 706 $action_object_constructor->($action_object_class); 707 1; 708 }; 709 $fatal_error = $EVAL_ERROR; 710 } ## end DO_EVAL: 711 712 if ( not $eval_ok or @warnings ) { 713 Marpa::XS::Internal::code_problems( 714 { fatal_error => $fatal_error, 715 grammar => $grammar, 716 eval_ok => $eval_ok, 717 warnings => \@warnings, 718 where => 'constructing action object', 719 } 720 ); 721 } ## end if ( not $eval_ok or @warnings ) 722 } ## end if ($action_object_constructor) 723 724 $action_object //= {}; 725 726 $recce_c->val_new(); 727 my @evaluation_stack = (); 728 $recce_c->val_trace( $trace_values ? 1 : 0 ); 729 730 EVENT: 731 while (1) { 732 my ( $token_id, $value_ix, $rule_id, $arg_0, $arg_n ) = 733 $recce_c->val_event(); 734 last EVENT if not defined $arg_n; 735 if ( $trace_values >= 3 ) { 736 for my $i ( reverse 0 .. $arg_n-1 ) { 737 printf {$Marpa::XS::Internal::TRACE_FH} 'Stack position %3d:', 738 $i 739 or Marpa::XS::exception('print to trace handle failed'); 740 print {$Marpa::XS::Internal::TRACE_FH} q{ }, 741 Data::Dumper->new( [ $evaluation_stack[$i] ] )->Terse(1) 742 ->Dump 743 or Marpa::XS::exception('print to trace handle failed'); 744 } ## end for my $i ( reverse 0 .. $arg_n ) 745 } ## end if ( $trace_values >= 3 ) 746 747 ADD_TOKEN: { 748 last ADD_TOKEN if not defined $token_id; 749 my $value_ref = 750 $value_ix >= 0 751 ? \( $token_values->[$value_ix] ) 752 : \$null_values->[$token_id]; 753 754 $evaluation_stack[$arg_n] = $value_ref; 755 756 last ADD_TOKEN if not $trace_values; 757 758 my $fork_ix = $recce_c->val_fork(); 759 my $or_node_id = $recce_c->fork_or_node($fork_ix); 760 my $choice = $recce_c->fork_choice($fork_ix); 761 my $and_node_id = 762 $recce_c->and_node_order_get( $or_node_id, $choice ); 763 my $token_name; 764 if ( defined $token_id ) { 765 $token_name = 766 $symbols->[$token_id] 767 ->[Marpa::XS::Internal::Symbol::NAME]; 768 } 769 770 print {$Marpa::XS::Internal::TRACE_FH} 771 'Pushed value from ', 772 Marpa::XS::Recognizer::and_node_tag( $recce, $and_node_id ), 773 ': ', 774 ( $token_name ? qq{$token_name = } : q{} ), 775 Data::Dumper->new( [$value_ref] )->Terse(1)->Dump 776 or Marpa::XS::exception('print to trace handle failed'); 777 778 } ## end ADD_TOKEN: 779 780 TRACE_OP: { 781 782 last TRACE_OP if not $trace_values; 783 784 my $fork_ix = $recce_c->val_fork(); 785 my $or_node_id = $recce_c->fork_or_node($fork_ix); 786 my $choice = $recce_c->fork_choice($fork_ix); 787 my $and_node_id = 788 $recce_c->and_node_order_get( $or_node_id, $choice ); 789 my $trace_rule_id = $recce_c->or_node_rule($or_node_id); 790 my $virtual_rhs = $grammar_c->rule_is_virtual_rhs($trace_rule_id); 791 my $virtual_lhs = $grammar_c->rule_is_virtual_lhs($trace_rule_id); 792 793 next EVENT 794 if $recce_c->or_node_position($or_node_id) 795 != $grammar_c->rule_length($trace_rule_id); 796 797 if ( not $virtual_rhs and not $virtual_lhs ) { 798 799 my $argc = $grammar_c->rule_length($trace_rule_id); 800 801 say {$Marpa::XS::Internal::TRACE_FH} 'Popping ', $argc, 802 ' values to evaluate ', 803 Marpa::XS::Recognizer::and_node_tag( 804 $recce, $and_node_id 805 ), 806 ', rule: ', $grammar->brief_rule($trace_rule_id) 807 or Marpa::XS::exception('Could not print to trace file'); 808 809 last TRACE_OP; 810 811 } ## end if ( not $virtual_rhs and not $virtual_lhs ) 812 813 if ( $virtual_rhs and not $virtual_lhs ) { 814 815 say {$Marpa::XS::Internal::TRACE_FH} 816 'Head of Virtual Rule: ', 817 Marpa::XS::Recognizer::and_node_tag( 818 $recce, $and_node_id 819 ), 820 ', rule: ', $grammar->brief_rule($trace_rule_id), 821 "\n", 822 'Incrementing virtual rule by ', 823 $grammar_c->real_symbol_count($trace_rule_id), ' symbols' 824 or Marpa::XS::exception('Could not print to trace file'); 825 826 last TRACE_OP; 827 828 } ## end if ( $virtual_rhs and not $virtual_lhs ) 829 830 if ( $virtual_lhs and $virtual_rhs ) { 831 832 say {$Marpa::XS::Internal::TRACE_FH} 833 'Virtual Rule: ', 834 Marpa::XS::Recognizer::and_node_tag( 835 $recce, $and_node_id 836 ), 837 ', rule: ', $grammar->brief_rule($trace_rule_id), 838 "\nAdding ", $grammar_c->real_symbol_count($trace_rule_id) 839 or Marpa::XS::exception('Could not print to trace file'); 840 841 next EVENT; 842 843 } ## end if ( $virtual_lhs and $virtual_rhs ) 844 845 if ( not $virtual_rhs and $virtual_lhs ) { 846 847 say {$Marpa::XS::Internal::TRACE_FH} 848 'New Virtual Rule: ', 849 Marpa::XS::Recognizer::and_node_tag( 850 $recce, $and_node_id 851 ), 852 ', rule: ', $grammar->brief_rule($trace_rule_id), 853 "\nReal symbol count is ", 854 $grammar_c->real_symbol_count($trace_rule_id) 855 or Marpa::XS::exception('Could not print to trace file'); 856 857 next EVENT; 858 859 } ## end if ( not $virtual_rhs and $virtual_lhs ) 860 861 } ## end TRACE_OP: 862 863 next EVENT if not defined $rule_id; 864 865 my $closure = $rule_closures->[$rule_id]; 866 if ( defined $closure ) { 867 my $result; 868 869 my @args = map { ${$_} } @evaluation_stack[ $arg_0 .. $arg_n ]; 870 if ( $grammar_c->rule_is_discard_separation($rule_id) ) { 871 @args = 872 @args[ map { 2 * $_ } 873 ( 0 .. ( scalar @args + 1 ) / 2 - 1 ) ]; 874 } 875 876 my @warnings; 877 my $eval_ok; 878 DO_EVAL: { 879 local $SIG{__WARN__} = sub { 880 push @warnings, [ $_[0], ( caller 0 ) ]; 881 }; 882 883 $eval_ok = eval { 884 $result = $closure->( $action_object, @args ); 885 1; 886 }; 887 888 } ## end DO_EVAL: 889 890 if ( not $eval_ok or @warnings ) { 891 my $fatal_error = $EVAL_ERROR; 892 Marpa::XS::Internal::code_problems( 893 { fatal_error => $fatal_error, 894 grammar => $grammar, 895 eval_ok => $eval_ok, 896 warnings => \@warnings, 897 where => 'computing value', 898 long_where => 'Computing value for rule: ' 899 . $grammar->brief_rule($rule_id), 900 } 901 ); 902 } ## end if ( not $eval_ok or @warnings ) 903 904 $evaluation_stack[$arg_0] = \$result; 905 906 if ($trace_values) { 907 print {$Marpa::XS::Internal::TRACE_FH} 908 'Calculated and pushed value: ', 909 Data::Dumper->new( [$result] )->Terse(1)->Dump 910 or Marpa::XS::exception('print to trace handle failed'); 911 } ## end if ($trace_values) 912 913 next EVENT; 914 915 } ## end if ( defined $closure ) 916 917 { 918 my $constant_result = $rule_constants->[$rule_id]; 919 $evaluation_stack[$arg_0] = $constant_result; 920 if ($trace_values) { 921 print {$Marpa::XS::Internal::TRACE_FH} 922 'Constant result: ', 923 'Pushing 1 value on stack: ', 924 Data::Dumper->new( [$constant_result] )->Terse(1)->Dump 925 or Marpa::XS::exception('Could not print to trace file'); 926 } ## end if ($trace_values) 927 } ## end when (Marpa::XS::Internal::Op::CONSTANT_RESULT) 928 } ## end while (1) 929 930 my $top_value = $evaluation_stack[0]; 931 932 return $top_value; 933 934} ## end sub Marpa::XS::Internal::Recognizer::evaluate 935 936# Returns false if no parse 937sub Marpa::XS::Recognizer::value { 938 my ( $recce, @arg_hashes ) = @_; 939 940 my $recce_c = $recce->[Marpa::XS::Internal::Recognizer::C]; 941 942 my $parse_set_arg = $recce->[Marpa::XS::Internal::Recognizer::END]; 943 944 my $parse_count = $recce_c->parse_count() // 0; 945 946 $recce->set(@arg_hashes); 947 948 local $Marpa::XS::Internal::TRACE_FH = 949 $recce->[Marpa::XS::Internal::Recognizer::TRACE_FILE_HANDLE]; 950 951 my $max_parses = $recce->[Marpa::XS::Internal::Recognizer::MAX_PARSES]; 952 if ( $max_parses and $parse_count > $max_parses ) { 953 Marpa::XS::exception("Maximum parse count ($max_parses) exceeded"); 954 } 955 956 my $furthest_earleme = $recce_c->furthest_earleme(); 957 my $last_completed_earleme = $recce_c->current_earleme(); 958 Marpa::XS::exception( 959 "Attempt to evaluate incompletely recognized parse:\n", 960 " Last token ends at location $furthest_earleme\n", 961 " Recognition done only as far as location $last_completed_earleme\n" 962 ) if $furthest_earleme > $last_completed_earleme; 963 964 my $top_or_node_id; 965 if ( not $parse_count ) { 966 967 # Perhaps this call should be moved. 968 # The null values are currently a function of the grammar, 969 # and should be constant for the life of a recognizer. 970 $recce->[Marpa::XS::Internal::Recognizer::NULL_VALUES] //= 971 Marpa::XS::Internal::Recognizer::set_null_values($recce); 972 Marpa::XS::Internal::Recognizer::set_actions($recce); 973 974 $recce_c->eval_clear(); 975 $top_or_node_id = 976 $recce_c->eval_setup( -1, ( $parse_set_arg // -1 ) ); 977 978 # No parse 979 return if not defined $top_or_node_id; 980 981 $recce->[Marpa::XS::Internal::Recognizer::TOP_OR_NODE_ID] = 982 $top_or_node_id; 983 984 given ( $recce->[Marpa::XS::Internal::Recognizer::RANKING_METHOD] ) { 985 when ('high_rule_only') { do_high_rule_only($recce); } 986 when ('rule') { do_rank_by_rule($recce); } 987 } 988 989 } ## end if ( not $parse_count ) 990 991 if ( $recce->[Marpa::XS::Internal::Recognizer::TRACE_AND_NODES] ) { 992 print {$Marpa::XS::Internal::TRACE_FH} 'AND_NODES: ', 993 $recce->show_and_nodes() 994 or Marpa::XS::exception('print to trace handle failed'); 995 } 996 997 if ( $recce->[Marpa::XS::Internal::Recognizer::TRACE_OR_NODES] ) { 998 print {$Marpa::XS::Internal::TRACE_FH} 'OR_NODES: ', 999 $recce->show_or_nodes() 1000 or Marpa::XS::exception('print to trace handle failed'); 1001 } 1002 1003 if ( $recce->[Marpa::XS::Internal::Recognizer::TRACE_BOCAGE] ) { 1004 print {$Marpa::XS::Internal::TRACE_FH} 'BOCAGE: ', 1005 $recce->show_bocage() 1006 or Marpa::XS::exception('print to trace handle failed'); 1007 } 1008 1009 $recce_c->tree_new(); 1010 return if not defined $recce_c->tree_size(); 1011 return Marpa::XS::Internal::Recognizer::evaluate($recce); 1012 1013} ## end sub Marpa::XS::Recognizer::value 1014 10151; 1016